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

factor: GENERIC: -> GENERIC: ; and GENERIC# HOOK: MATH: too

locals-and-roots
Doug Coleman 2016-06-03 19:35:04 -07:00
parent cca9402fe6
commit 41b3d5bb0a
585 changed files with 2334 additions and 2334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
apps/webbrowser/webbrowser.factor
View File

@ -6,7 +6,7 @@ sequences strings system ui.operations urls vocabs ;
IN: webbrowser
HOOK: open-file os ( path -- )
HOOK: open-file os ( path -- ) ;
"webbrowser." os name>> append require

2
benchmarks/benchmark/binary-trees/binary-trees.factor
View File

@ -18,7 +18,7 @@ C: <tree-node> tree-node
drop f f
] if <tree-node> ; inline recursive
GENERIC: item-check ( node -- n )
GENERIC: item-check ( node -- n ) ;
M: tree-node item-check
[ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;

2
benchmarks/benchmark/dispatch1/dispatch1.factor
View File

@ -1,7 +1,7 @@
USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )
GENERIC: g ( obj -- obj ) ;
TUPLE: x1 ;
M: x1 g ;

2
benchmarks/benchmark/dispatch3/dispatch3.factor
View File

@ -4,7 +4,7 @@ specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
GENERIC: g ( obj -- str ) ;
M: assoc g drop "assoc" ;

2
benchmarks/benchmark/raytracer/raytracer.factor
View File

@ -34,7 +34,7 @@ TUPLE: hit { normal double-array read-only } { lambda float read-only } ;
C: <hit> hit
GENERIC: intersect-scene ( hit ray scene -- hit )
GENERIC: intersect-scene ( hit ray scene -- hit ) ;
TUPLE: sphere { center double-array read-only } { radius float read-only } ;

18
collections/arrays/shaped/shaped.factor
View File

@ -7,7 +7,7 @@ IN: arrays.shaped
: flat? ( array -- ? ) [ sequence? ] any? not ; inline
GENERIC: array-replace ( object -- shape )
GENERIC: array-replace ( object -- shape ) ;
M: f array-replace ;
@ -26,7 +26,7 @@ C: <uniform-shape> uniform-shape
TUPLE: abnormal-shape shape ;
C: <abnormal-shape> abnormal-shape
GENERIC: wrap-shape ( object -- shape )
GENERIC: wrap-shape ( object -- shape ) ;
M: integer wrap-shape
1array <uniform-shape> ;
@ -38,7 +38,7 @@ M: sequence wrap-shape
<abnormal-shape>
] if ;
GENERIC: shape ( array -- shape )
GENERIC: shape ( array -- shape ) ;
M: sequence shape array-replace wrap-shape ;
@ -49,7 +49,7 @@ ERROR: no-negative-shape-components shape ;
: check-shape-domain ( seq -- seq )
dup [ 0 < ] any? [ no-negative-shape-components ] when ;
GENERIC: shape-capacity ( shape -- n )
GENERIC: shape-capacity ( shape -- n ) ;
M: sequence shape-capacity check-shape-domain product ;
@ -65,7 +65,7 @@ ERROR: underlying-shape-mismatch underlying shape ;
ERROR: no-abnormally-shaped-arrays underlying shape ;
GENERIC: check-underlying-shape ( underlying shape -- underlying shape )
GENERIC: check-underlying-shape ( underlying shape -- underlying shape ) ;
M: abnormal-shape check-underlying-shape
no-abnormally-shaped-arrays ;
@ -105,9 +105,9 @@ M: shaped-array shape shape>> ;
: <col-array> ( underlying shape -- shaped-array )
col-array make-shaped-array ; inline
GENERIC: >shaped-array ( array -- shaped-array )
GENERIC: >row-array ( array -- shaped-array )
GENERIC: >col-array ( array -- shaped-array )
GENERIC: >shaped-array ( array -- shaped-array ) ;
GENERIC: >row-array ( array -- shaped-array ) ;
GENERIC: >col-array ( array -- shaped-array ) ;
M: sequence >shaped-array
[ { } flatten-as ] [ shape ] bi <shaped-array> ;
@ -171,7 +171,7 @@ TUPLE: transposed shaped-array ;
TUPLE: row-traverser shaped-array index ;
GENERIC: next-index ( object -- index )
GENERIC: next-index ( object -- index ) ;
SYNTAX: sa{ \ } [ >shaped-array ] parse-literal ;

2
collections/assocs/extras/extras.factor
View File

@ -40,7 +40,7 @@ IN: assocs.extras
[ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
[ assoc-merge! ] bi@ ;
GENERIC: delete-value-at ( value assoc -- )
GENERIC: delete-value-at ( value assoc -- ) ;
M: assoc delete-value-at
[ value-at* ] keep swap [ delete-at ] [ 2drop ] if ;

4
collections/bit-arrays/bit-arrays.factor
View File

@ -59,11 +59,11 @@ M: bit-array nth-unsafe
M: bit-array set-nth-unsafe
bit-index [ toggle-bit ] change-nth-unsafe ; inline
GENERIC: clear-bits ( bit-array -- )
GENERIC: clear-bits ( bit-array -- ) ;
M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- )
GENERIC: set-bits ( bit-array -- ) ;
M: bit-array set-bits -1 (set-bits) ; inline

4
collections/bitstreams/bitstreams.factor
View File

@ -62,8 +62,8 @@ TUPLE: lsb0-bit-writer < bit-writer ;
: <lsb0-bit-writer> ( -- bs )
lsb0-bit-writer new-bit-writer ;
GENERIC: peek ( n bitstream -- value )
GENERIC: poke ( value n bitstream -- )
GENERIC: peek ( n bitstream -- value ) ;
GENERIC: poke ( value n bitstream -- ) ;
: get-abp ( bitstream -- abp )
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline

44
collections/cursors/cursors.factor
View File

@ -12,12 +12,12 @@ IN: cursors
MIXIN: cursor
GENERIC: cursor-compatible? ( cursor cursor -- ? )
GENERIC: cursor-valid? ( cursor -- ? )
GENERIC: cursor= ( cursor cursor -- ? )
GENERIC: cursor<= ( cursor cursor -- ? )
GENERIC: cursor>= ( cursor cursor -- ? )
GENERIC: cursor-distance-hint ( cursor cursor -- n )
GENERIC: cursor-compatible? ( cursor cursor -- ? ) ;
GENERIC: cursor-valid? ( cursor -- ? ) ;
GENERIC: cursor= ( cursor cursor -- ? ) ;
GENERIC: cursor<= ( cursor cursor -- ? ) ;
GENERIC: cursor>= ( cursor cursor -- ? ) ;
GENERIC: cursor-distance-hint ( cursor cursor -- n ) ;
M: cursor cursor<= cursor= ; inline
M: cursor cursor>= cursor= ; inline
@ -30,21 +30,21 @@ M: cursor cursor-distance-hint 2drop 0 ; inline
MIXIN: forward-cursor
INSTANCE: forward-cursor cursor
GENERIC: inc-cursor ( cursor -- cursor' )
GENERIC: inc-cursor ( cursor -- cursor' ) ;
MIXIN: bidirectional-cursor
INSTANCE: bidirectional-cursor forward-cursor
GENERIC: dec-cursor ( cursor -- cursor' )
GENERIC: dec-cursor ( cursor -- cursor' ) ;
MIXIN: random-access-cursor
INSTANCE: random-access-cursor bidirectional-cursor
GENERIC# cursor+ 1 ( cursor n -- cursor' )
GENERIC# cursor- 1 ( cursor n -- cursor' )
GENERIC: cursor-distance ( cursor cursor -- n )
GENERIC: cursor< ( cursor cursor -- ? )
GENERIC: cursor> ( cursor cursor -- ? )
GENERIC# cursor+ 1 ( cursor n -- cursor' ) ;
GENERIC# cursor- 1 ( cursor n -- cursor' ) ;
GENERIC: cursor-distance ( cursor cursor -- n ) ;
GENERIC: cursor< ( cursor cursor -- ? ) ;
GENERIC: cursor> ( cursor cursor -- ? ) ;
M: random-access-cursor inc-cursor 1 cursor+ ; inline
M: random-access-cursor dec-cursor -1 cursor+ ; inline
@ -61,9 +61,9 @@ ERROR: invalid-cursor cursor ;
MIXIN: input-cursor
GENERIC: cursor-key-value ( cursor -- key value )
GENERIC: cursor-key-value ( cursor -- key value ) ;
<PRIVATE
GENERIC: cursor-key-value-unsafe ( cursor -- key value )
GENERIC: cursor-key-value-unsafe ( cursor -- key value ) ;
PRIVATE>
M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
M: input-cursor cursor-key-value
@ -83,9 +83,9 @@ M: input-cursor cursor-key-value
MIXIN: output-cursor
GENERIC: set-cursor-value ( value cursor -- )
GENERIC: set-cursor-value ( value cursor -- ) ;
<PRIVATE
GENERIC: set-cursor-value-unsafe ( value cursor -- )
GENERIC: set-cursor-value-unsafe ( value cursor -- ) ;
PRIVATE>
M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline
M: output-cursor set-cursor-value
@ -114,7 +114,7 @@ INSTANCE: finite-stream-cursor stream-cursor
SINGLETON: end-of-stream
GENERIC: cursor-stream-ended? ( cursor -- ? )
GENERIC: cursor-stream-ended? ( cursor -- ? ) ;
M: finite-stream-cursor inc-cursor
dup cursor-stream-ended? [ drop end-of-stream ] when ; inline
@ -189,7 +189,7 @@ M: linear-cursor cursor+
M: linear-cursor cursor-
[ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep <linear-cursor> ; inline
GENERIC: up/i ( distance delta -- distance' )
GENERIC: up/i ( distance delta -- distance' ) ;
M: integer up/i [ 1 - + ] keep /i ; inline
M: real up/i / ceiling >integer ; inline
@ -223,8 +223,8 @@ M: quadratic-cursor dec-cursor
MIXIN: collection
GENERIC: begin-cursor ( collection -- cursor )
GENERIC: end-cursor ( collection -- cursor )
GENERIC: begin-cursor ( collection -- cursor ) ;
GENERIC: end-cursor ( collection -- cursor ) ;
: all ( collection -- begin end )
[ begin-cursor ] [ end-cursor ] bi ; inline
@ -391,7 +391,7 @@ M: pusher-cursor set-cursor-value growable>> push ; inline
: new-growable-cursor ( begin end exemplar -- cursor result )
[ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result ) ;
M: random-access-cursor new-sequence-cursor
[ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline

22
collections/deques/deques.factor
View File

@ -3,17 +3,17 @@
USING: fry kernel sequences ;
IN: deques
GENERIC: push-front* ( obj deque -- node )
GENERIC: push-back* ( obj deque -- node )
GENERIC: peek-front* ( deque -- obj ? )
GENERIC: peek-back* ( deque -- obj ? )
GENERIC: pop-front* ( deque -- )
GENERIC: pop-back* ( deque -- )
GENERIC: delete-node ( node deque -- )
GENERIC: deque-member? ( value deque -- ? )
GENERIC: clear-deque ( deque -- )
GENERIC: node-value ( node -- value )
GENERIC: deque-empty? ( deque -- ? )
GENERIC: push-front* ( obj deque -- node ) ;
GENERIC: push-back* ( obj deque -- node ) ;
GENERIC: peek-front* ( deque -- obj ? ) ;
GENERIC: peek-back* ( deque -- obj ? ) ;
GENERIC: pop-front* ( deque -- ) ;
GENERIC: pop-back* ( deque -- ) ;
GENERIC: delete-node ( node deque -- ) ;
GENERIC: deque-member? ( value deque -- ? ) ;
GENERIC: clear-deque ( deque -- ) ;
GENERIC: node-value ( node -- value ) ;
GENERIC: deque-empty? ( deque -- ? ) ;
ERROR: empty-deque ;

14
collections/disjoint-sets/disjoint-sets.factor
View File

@ -25,7 +25,7 @@ TUPLE: disjoint-set
PRIVATE>
GENERIC: representative ( a disjoint-set -- p )
GENERIC: representative ( a disjoint-set -- p ) ;
M:: disjoint-set representative ( a disjoint-set -- p )
a disjoint-set parents>> at :> p
@ -51,7 +51,7 @@ PRIVATE>
: <disjoint-set> ( -- disjoint-set )
H{ } clone H{ } clone H{ } clone disjoint-set boa ;
GENERIC: add-atom ( a disjoint-set -- )
GENERIC: add-atom ( a disjoint-set -- ) ;
M: disjoint-set add-atom
[ dupd parents>> set-at ]
@ -61,24 +61,24 @@ M: disjoint-set add-atom
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
GENERIC: disjoint-set-member? ( a disjoint-set -- ? ) ;
M: disjoint-set disjoint-set-member? parents>> key? ;
GENERIC: disjoint-set-members ( disjoint-set -- seq )
GENERIC: disjoint-set-members ( disjoint-set -- seq ) ;
M: disjoint-set disjoint-set-members parents>> keys ;
GENERIC: equiv-set-size ( a disjoint-set -- n )
GENERIC: equiv-set-size ( a disjoint-set -- n ) ;
M: disjoint-set equiv-set-size
[ representative ] keep counts>> at ;
GENERIC: equiv? ( a b disjoint-set -- ? )
GENERIC: equiv? ( a b disjoint-set -- ? ) ;
M: disjoint-set equiv? representatives = ;
GENERIC: equate ( a b disjoint-set -- )
GENERIC: equate ( a b disjoint-set -- ) ;
M:: disjoint-set equate ( a b disjoint-set -- )
a b disjoint-set representatives

4
collections/documents/elements/elements.factor
View File

@ -4,8 +4,8 @@ USING: arrays combinators documents fry kernel math sequences
accessors unicode combinators.short-circuit ;
IN: documents.elements
GENERIC: prev-elt ( loc document elt -- newloc )
GENERIC: next-elt ( loc document elt -- newloc )
GENERIC: prev-elt ( loc document elt -- newloc ) ;
GENERIC: next-elt ( loc document elt -- newloc ) ;
: prev/next-elt ( loc document elt -- start end )
[ prev-elt ] [ next-elt ] 3bi ;

2
collections/hash-sets/wrapped/wrapped.factor
View File

@ -12,7 +12,7 @@ TUPLE: wrapped-key
TUPLE: wrapped-hash-set
{ underlying hash-set read-only } ;
GENERIC: wrap-key ( key wrapped-hash -- wrapped-key )
GENERIC: wrap-key ( key wrapped-hash -- wrapped-key ) ;
<PRIVATE

16
collections/heaps/heaps.factor
View File

@ -6,13 +6,13 @@ math math.order math.private sequences sequences.private summary
vectors ;
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key )
GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-empty? ( heap -- ? )
GENERIC: heap-size ( heap -- n )
GENERIC: heap-push* ( value key heap -- entry ) ;
GENERIC: heap-peek ( heap -- value key ) ;
GENERIC: heap-pop* ( heap -- ) ;
GENERIC: heap-pop ( heap -- value key ) ;
GENERIC: heap-delete ( entry heap -- ) ;
GENERIC: heap-empty? ( heap -- ? ) ;
GENERIC: heap-size ( heap -- n ) ;
<PRIVATE
@ -71,7 +71,7 @@ M: heap heap-size ( heap -- n )
[ heap-size [ >>index ] keep ]
[ data>> [ set-nth ] 2keep drop ] bi ; inline
GENERIC: heap-compare ( entry1 entry2 heap -- ? )
GENERIC: heap-compare ( entry1 entry2 heap -- ? ) ;
M: min-heap heap-compare
drop { entry entry } declare [ key>> ] bi@ after? ; inline

2
collections/io/files/trash/trash.factor
View File

@ -5,7 +5,7 @@ USING: combinators system vocabs ;
IN: io.files.trash
HOOK: send-to-trash os ( path -- )
HOOK: send-to-trash os ( path -- ) ;
{
{ [ os windows? ] [ "io.files.trash.windows" ] }

6
collections/io/serial/serial.factor
View File

@ -12,9 +12,9 @@ M: invalid-baud summary ( invalid-baud -- string )
baud>> number>string
"Baud rate " " not supported" surround ;
HOOK: lookup-baud os ( m -- n )
HOOK: open-serial os ( serial -- serial' )
HOOK: default-serial-flags os ( m -- n )
HOOK: lookup-baud os ( m -- n ) ;
HOOK: open-serial os ( serial -- serial' ) ;
HOOK: default-serial-flags os ( m -- n ) ;
M: serial-port dispose* ( serial -- ) stream>> dispose ;
: <serial-port> ( path baud -- obj )

8
collections/lists/lists.factor
View File

@ -6,9 +6,9 @@ IN: lists
! List Protocol
MIXIN: list
GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr )
GENERIC: nil? ( object -- ? )
GENERIC: car ( cons -- car ) ;
GENERIC: cdr ( cons -- cdr ) ;
GENERIC: nil? ( object -- ? ) ;
TUPLE: cons-state { car read-only } { cdr read-only } ;
@ -99,6 +99,6 @@ PRIVATE>
INSTANCE: cons-state list
INSTANCE: +nil+ list
GENERIC: >list ( object -- list )
GENERIC: >list ( object -- list ) ;
M: list >list ;

4
collections/persistent/assocs/assocs.factor
View File

@ -3,11 +3,11 @@
USING: kernel assocs ;
IN: persistent.assocs
GENERIC: new-at ( value key assoc -- assoc' )
GENERIC: new-at ( value key assoc -- assoc' ) ;
M: assoc new-at clone [ set-at ] keep ;
GENERIC: pluck-at ( key assoc -- assoc' )
GENERIC: pluck-at ( key assoc -- assoc' ) ;
M: assoc pluck-at clone [ delete-at ] keep ;

8
collections/persistent/hashtables/nodes/nodes.factor
View File

@ -38,13 +38,13 @@ TUPLE: bitmap-node
[ <full-node> nip ]
[ over first hashcode>> bitmap-node boa ] if ;
GENERIC: (entry-at) ( key hashcode node -- entry )
GENERIC: (entry-at) ( key hashcode node -- entry ) ;
GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf )
GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf ) ;
GENERIC: (pluck-at) ( key hashcode node -- node' )
GENERIC: (pluck-at) ( key hashcode node -- node' ) ;
GENERIC: >alist% ( node -- )
GENERIC: >alist% ( node -- ) ;
: >alist-each% ( nodes -- ) [ >alist% ] each ;

6
collections/persistent/heaps/heaps.factor
View File

@ -34,7 +34,7 @@ PRIVATE>
: both-with? ( obj a b quot -- ? )
swap [ with ] dip swap both? ; inline
GENERIC: sift-down ( value prio left right -- heap )
GENERIC: sift-down ( value prio left right -- heap ) ;
: singleton-sift-down ( value prio singleton empty -- heap )
2over prio>> <= [ <branch> ] [
@ -61,11 +61,11 @@ M: branch sift-down ! both arguments are branches
] if ;
PRIVATE>
GENERIC: pheap-peek ( heap -- value prio )
GENERIC: pheap-peek ( heap -- value prio ) ;
M: empty-heap pheap-peek empty-pheap ;
M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
GENERIC: pheap-push ( value prio heap -- newheap )
GENERIC: pheap-push ( value prio heap -- newheap ) ;
M: empty-heap pheap-push
drop <singleton-heap> ;

6
collections/persistent/sequences/sequences.factor
View File

@ -3,15 +3,15 @@
USING: sequences kernel ;
IN: persistent.sequences
GENERIC: ppush ( val seq -- seq' )
GENERIC: ppush ( val seq -- seq' ) ;
M: sequence ppush swap suffix ;
GENERIC: ppop ( seq -- seq' )
GENERIC: ppop ( seq -- seq' ) ;
M: sequence ppop but-last ;
GENERIC: new-nth ( val i seq -- seq' )
GENERIC: new-nth ( val i seq -- seq' ) ;
M: sequence new-nth clone [ set-nth ] keep ;

2
collections/sequences/cords/cords.factor
View File

@ -22,7 +22,7 @@ M: cord virtual@
INSTANCE: cord virtual-sequence
GENERIC: cord-append ( seq1 seq2 -- cord )
GENERIC: cord-append ( seq1 seq2 -- cord ) ;
M: object cord-append
generic-cord boa ; inline

2
collections/sequences/deep/deep.factor
View File

@ -5,7 +5,7 @@ IN: sequences.deep
! All traversal goes in postorder
GENERIC: branch? ( object -- ? )
GENERIC: branch? ( object -- ? ) ;
M: sequence branch? drop t ;
M: integer branch? drop f ;

4
collections/sequences/modified/modified.factor
View File

@ -6,11 +6,11 @@ IN: sequences.modified
TUPLE: modified ;
GENERIC: modified-nth ( n seq -- elt )
GENERIC: modified-nth ( n seq -- elt ) ;
M: modified nth modified-nth ;
M: modified nth-unsafe modified-nth ;
GENERIC: modified-set-nth ( elt n seq -- )
GENERIC: modified-set-nth ( elt n seq -- ) ;
M: modified set-nth modified-set-nth ;
M: modified set-nth-unsafe modified-set-nth ;

6
collections/specialized-arrays/specialized-arrays.factor
View File

@ -17,7 +17,7 @@ INSTANCE: specialized-array sequence
: <underlying> ( n type -- array )
heap-size * <byte-array> ; inline
GENERIC: underlying-type ( c-type -- c-type' )
GENERIC: underlying-type ( c-type -- c-type' ) ;
M: c-type-word underlying-type
dup "c-type" word-prop {
@ -32,8 +32,8 @@ M: pointer underlying-type
<PRIVATE
GENERIC: nth-c-ptr ( n seq -- displaced-alien )
GENERIC: direct-like ( alien len exemplar -- seq )
GENERIC: nth-c-ptr ( n seq -- displaced-alien ) ;
GENERIC: direct-like ( alien len exemplar -- seq ) ;
M: byte-array nth-c-ptr <displaced-alien> ; inline
M: byte-array direct-like drop uchar <c-direct-array> ; inline

2
collections/trees/avl/avl.factor
View File

@ -131,7 +131,7 @@ M: avl set-at ( value key node -- )
left [ replace-with-a-child ] with-side
] if ;
GENERIC: avl-delete ( key node -- node shorter? deleted? )
GENERIC: avl-delete ( key node -- node shorter? deleted? ) ;
M: f avl-delete ( key f -- f f f ) nip f f ;

8
core/alien/alien.factor
View File

@ -21,7 +21,7 @@ PREDICATE: pinned-alien < alien underlying>> not ;
UNION: pinned-c-ptr pinned-alien postpone: f ;
GENERIC: element-size ( seq -- n ) flushable
GENERIC: element-size ( seq -- n ) ; flushable
M: byte-array element-size drop 1 ; inline
@ -31,11 +31,11 @@ M: slice element-size seq>> element-size ; inline
M: f element-size drop 1 ; inline
GENERIC: byte-length ( obj -- n ) flushable
GENERIC: byte-length ( obj -- n ) ; flushable
M: object byte-length [ length ] [ element-size ] bi * ; inline
GENERIC: >c-ptr ( obj -- c-ptr ) flushable
GENERIC: >c-ptr ( obj -- c-ptr ) ; flushable
M: c-ptr >c-ptr ; inline
@ -50,7 +50,7 @@ M: object >c-ptr underlying>> ; inline
: binary-object ( obj -- c-ptr n )
[ >c-ptr ] [ byte-length ] bi ; inline
GENERIC: expired? ( c-ptr -- ? ) flushable
GENERIC: expired? ( c-ptr -- ? ) ; flushable
M: alien expired? expired>> ;

4
core/alien/c-types/c-types-tests.factor
View File

@ -128,7 +128,7 @@ must-fail-with
"IN: alien.c-types.tests
use: alien.syntax
use: alien.c-types
GENERIC: foo-func ( x -- )
GENERIC: foo-func ( x -- ) ;
" eval( -- )
"IN: alien.c-types.tests
@ -141,7 +141,7 @@ CALLBACK: void foo-func ( )
"IN: alien.c-types.tests
use: alien.syntax
use: alien.c-types
GENERIC: foo-func ( x -- )
GENERIC: foo-func ( x -- ) ;
" eval( -- )
"IN: alien.c-types.tests

28
core/alien/c-types/c-types.factor
View File

@ -42,7 +42,7 @@ ERROR: no-c-type word ;
M: no-c-type summary drop "Not a C type" ;
! C type protocol
GENERIC: lookup-c-type ( name -- c-type ) foldable
GENERIC: lookup-c-type ( name -- c-type ) ; foldable
PREDICATE: c-type-word < word
"c-type" word-prop >boolean ;
@ -61,57 +61,57 @@ M: word lookup-c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
GENERIC: c-type-class ( name -- class )
GENERIC: c-type-class ( name -- class ) ;
M: abstract-c-type c-type-class class>> ;
GENERIC: c-type-boxed-class ( name -- class )
GENERIC: c-type-boxed-class ( name -- class ) ;
M: abstract-c-type c-type-boxed-class boxed-class>> ;
GENERIC: c-type-boxer-quot ( name -- quot )
GENERIC: c-type-boxer-quot ( name -- quot ) ;
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
GENERIC: c-type-unboxer-quot ( name -- quot )
GENERIC: c-type-unboxer-quot ( name -- quot ) ;
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
GENERIC: c-type-rep ( name -- rep )
GENERIC: c-type-rep ( name -- rep ) ;
M: c-type c-type-rep rep>> ;
GENERIC: c-type-getter ( name -- quot )
GENERIC: c-type-getter ( name -- quot ) ;
M: c-type c-type-getter getter>> ;
GENERIC: c-type-copier ( name -- quot )
GENERIC: c-type-copier ( name -- quot ) ;
M: c-type c-type-copier drop [ ] ;
GENERIC: c-type-setter ( name -- quot )
GENERIC: c-type-setter ( name -- quot ) ;
M: c-type c-type-setter setter>> ;
GENERIC: c-type-signed ( name -- boolean ) foldable
GENERIC: c-type-signed ( name -- boolean ) ; foldable
M: abstract-c-type c-type-signed signed>> ;
GENERIC: c-type-align ( name -- n ) foldable
GENERIC: c-type-align ( name -- n ) ; foldable
M: abstract-c-type c-type-align align>> ;
GENERIC: c-type-align-first ( name -- n )
GENERIC: c-type-align-first ( name -- n ) ;
M: abstract-c-type c-type-align-first align-first>> ;
GENERIC: base-type ( c-type -- c-type )
GENERIC: base-type ( c-type -- c-type ) ;
M: c-type-name base-type lookup-c-type ;
M: c-type base-type ;
GENERIC: heap-size ( name -- size )
GENERIC: heap-size ( name -- size ) ;
M: abstract-c-type heap-size size>> ;

6
core/alien/libraries/libraries.factor
View File

@ -17,7 +17,7 @@ PRIMITIVE: (dlsym-raw) ( name dll -- alien ) ;
: dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
HOOK: dlerror os ( -- message/f )
HOOK: dlerror os ( -- message/f ) ;
symbol: libraries
@ -30,7 +30,7 @@ C: <library> library
: lookup-library ( name -- library ) libraries get at ;
ERROR: no-library-named name ;
GENERIC: dlsym? ( name string/dll -- ? )
GENERIC: dlsym? ( name string/dll -- ? ) ;
M: string dlsym? dup lookup-library [ nip dll>> dlsym? ] [ no-library-named ] if* ;
M: dll dlsym? dlsym >boolean ;
@ -98,7 +98,7 @@ deploy-libraries [ V{ } clone ] initialize
[ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
[ "deploy-library failure" no-such-library ] if ;
HOOK: >deployed-library-path os ( path -- path' )
HOOK: >deployed-library-path os ( path -- path' ) ;
! {
! { [ os windows? ] [ "alien.libraries.windows" ] }

10
core/alien/strings/strings.factor
View File

@ -7,7 +7,7 @@ namespaces sequences sequences.private strings strings.private
system system.private ;
in: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) ;
M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
@ -24,7 +24,7 @@ ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over member-eq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
GENERIC# string>alien 1 ( string encoding -- byte-array ) ;
M: c-ptr string>alien drop ;
@ -60,7 +60,7 @@ M: string string>alien
M: tuple string>alien drop underlying>> ;
HOOK: native-string-encoding os ( -- encoding ) foldable
HOOK: native-string-encoding os ( -- encoding ) ; foldable
M: unix native-string-encoding utf8 ;
@ -75,13 +75,13 @@ M: windows native-string-encoding utf16n ;
: dll-path ( dll -- string )
path>> alien>native-string ;
GENERIC: string>symbol ( str/seq -- alien )
GENERIC: string>symbol ( str/seq -- alien ) ;
M: string string>symbol utf8 string>alien ;
M: sequence string>symbol [ utf8 string>alien ] map ;
GENERIC: symbol>string ( symbol(s) -- string )
GENERIC: symbol>string ( symbol(s) -- string ) ;
M: byte-array symbol>string utf8 alien>string ;

24
core/assocs/assocs.factor
View File

@ -6,18 +6,18 @@ in: assocs
mixin: assoc
GENERIC: at* ( key assoc -- value/f ? )
GENERIC: value-at* ( value assoc -- key/f ? )
GENERIC: set-at ( value key assoc -- )
GENERIC: new-assoc ( capacity exemplar -- newassoc )
GENERIC: delete-at ( key assoc -- )
GENERIC: clear-assoc ( assoc -- )
GENERIC: assoc-size ( assoc -- n )
GENERIC: assoc-like ( assoc exemplar -- newassoc )
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
GENERIC: keys ( assoc -- keys )
GENERIC: values ( assoc -- values )
GENERIC: at* ( key assoc -- value/f ? ) ;
GENERIC: value-at* ( value assoc -- key/f ? ) ;
GENERIC: set-at ( value key assoc -- ) ;
GENERIC: new-assoc ( capacity exemplar -- newassoc ) ;
GENERIC: delete-at ( key assoc -- ) ;
GENERIC: clear-assoc ( assoc -- ) ;
GENERIC: assoc-size ( assoc -- n ) ;
GENERIC: assoc-like ( assoc exemplar -- newassoc ) ;
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) ;
GENERIC: >alist ( assoc -- newassoc ) ;
GENERIC: keys ( assoc -- keys ) ;
GENERIC: values ( assoc -- values ) ;
M: assoc assoc-like drop ; inline

12
core/checksums/checksums.factor
View File

@ -19,11 +19,11 @@ M: checksum-state clone
call-next-method
[ clone ] change-bytes ;
GENERIC: initialize-checksum-state ( checksum -- checksum-state )
GENERIC: initialize-checksum-state ( checksum -- checksum-state ) ;
GENERIC: checksum-block ( bytes checksum-state -- )
GENERIC: checksum-block ( bytes checksum-state -- ) ;
GENERIC: get-checksum ( checksum-state -- value )
GENERIC: get-checksum ( checksum-state -- value ) ;
: add-checksum-bytes ( checksum-state data -- checksum-state )
over bytes>> [ push-all ] keep
@ -43,11 +43,11 @@ GENERIC: get-checksum ( checksum-state -- value )
: add-checksum-file ( checksum-state path -- checksum-state )
normalize-path (file-reader) add-checksum-stream ;
GENERIC: checksum-bytes ( bytes checksum -- value )
GENERIC: checksum-bytes ( bytes checksum -- value ) ;
GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-stream ( stream checksum -- value ) ;
GENERIC: checksum-lines ( lines checksum -- value )
GENERIC: checksum-lines ( lines checksum -- value ) ;
M: checksum checksum-stream
[ stream-contents ] dip checksum-bytes ;

6
core/classes/algebra/algebra.factor
View File

@ -61,15 +61,15 @@ DEFER: (class<=)
DEFER: (class-not)
GENERIC: (classes-intersect?) ( first second -- ? )
GENERIC: (classes-intersect?) ( first second -- ? ) ;
DEFER: (class-and)
DEFER: (class-or)
GENERIC: (flatten-class) ( class -- )
GENERIC: (flatten-class) ( class -- ) ;
GENERIC: normalize-class ( class -- class' )
GENERIC: normalize-class ( class -- class' ) ;
M: object normalize-class ;

12
core/classes/classes-tests.factor
View File

@ -10,7 +10,7 @@ in: classes.tests
{ f } [ 3 null instance? ] unit-test
! Regression
GENERIC: method-forget-test ( obj -- obj )
GENERIC: method-forget-test ( obj -- obj ) ;
TUPLE: method-forget-class ;
M: method-forget-class method-forget-test ;
@ -31,7 +31,7 @@ use: multiline
! So the user has some code...
{ } [
"IN: classes.test.a
GENERIC: g ( a -- b )
GENERIC: g ( a -- b ) ;
TUPLE: x ;
M: x g ;
TUPLE: z < x ;" <string-reader>
@ -50,7 +50,7 @@ use: multiline
! Now, the user removes the z class and adds a method,
{ } [
"IN: classes.test.a
GENERIC: g ( a -- b )
GENERIC: g ( a -- b ) ;
TUPLE: x ;
M: x g ;
TUPLE: j ;
@ -71,7 +71,7 @@ use: multiline
{ } [
"IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
GENERIC: g ( a -- b ) ;
M: object g ;
TUPLE: z ;" <string-reader>
"class-intersect-no-method-c" parse-stream drop
@ -89,7 +89,7 @@ use: multiline
{ } [
"IN: classes.test.c
USE: kernel
GENERIC: g ( a -- b )
GENERIC: g ( a -- b ) ;
M: object g ;
TUPLE: j ;
M: j g ;" <string-reader>
@ -107,7 +107,7 @@ TUPLE: forgotten-predicate-test ;
{ } [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
{ f } [ \ forgotten-predicate-test? predicate? ] unit-test
GENERIC: generic-predicate? ( a -- b )
GENERIC: generic-predicate? ( a -- b ) ;
{ } [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test

22
core/classes/classes.factor
View File

@ -43,13 +43,13 @@ symbol: update-map
symbol: implementors-map
GENERIC: class-name ( class -- string )
GENERIC: class-name ( class -- string ) ;
M: class class-name name>> ;
GENERIC: rank-class ( class -- n )
GENERIC: rank-class ( class -- n ) ;
GENERIC: reset-class ( class -- )
GENERIC: reset-class ( class -- ) ;
M: class reset-class
{
@ -74,11 +74,11 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
[ name>> "?" append ] [ vocabulary>> ] bi create-word
dup predicate? [ dup reset-generic ] unless ;
GENERIC: class-of ( object -- class )
GENERIC: class-of ( object -- class ) ;
GENERIC: instance? ( object class -- ? ) flushable
GENERIC: instance? ( object class -- ? ) ; flushable
GENERIC: predicate-def ( obj -- quot )
GENERIC: predicate-def ( obj -- quot ) ;
M: word predicate-def
"predicate" word-prop ;
@ -121,7 +121,7 @@ M: predicate reset-word
! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: implementors ( class/classes -- seq )
GENERIC: implementors ( class/classes -- seq ) ;
! update-map
: class-uses ( class -- seq )
@ -166,7 +166,7 @@ M: sequence implementors [ implementors ] gather ;
} spread
] H{ } make ;
GENERIC: metaclass-changed ( use class -- )
GENERIC: metaclass-changed ( use class -- ) ;
: ?metaclass-changed ( class usages/f -- )
[ [ metaclass-changed ] with each ] [ drop ] if* ;
@ -201,11 +201,11 @@ GENERIC: metaclass-changed ( use class -- )
[ nip ?metaclass-changed ]
} 3cleave ;
GENERIC: update-class ( class -- )
GENERIC: update-class ( class -- ) ;
M: class update-class drop ;
GENERIC: update-methods ( class seq -- )
GENERIC: update-methods ( class seq -- ) ;
: update-classes ( class -- )
dup class-usages
@ -226,7 +226,7 @@ GENERIC: update-methods ( class seq -- )
[ forget ] [ drop ] if
] [ 2drop ] if ;
GENERIC: forget-methods ( class -- )
GENERIC: forget-methods ( class -- ) ;
PRIVATE>

2
core/classes/error/error-tests.factor
View File

@ -17,7 +17,7 @@ DEFER: error-y
{ } [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
{ } [ "IN: classes.error.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
{ } [ "IN: classes.error.tests GENERIC: error-y ( a -- b )" eval( -- ) ; ] unit-test
{ f } [ \ error-y tuple-class? ] unit-test

4
core/classes/intersection/intersection-tests.factor
View File

@ -8,7 +8,7 @@ INSTANCE: a3 b
INSTANCE: a1 b
INTERSECTION: c a2 b ;
GENERIC: x ( a -- b )
GENERIC: x ( a -- b ) ;
M: c x drop c ;
M: a x drop a ;
@ -29,7 +29,7 @@ TUPLE: t4 < t2 ; TUPLE: t5 < t2 ;
UNION: m t4 t5 t3 ;
INTERSECTION: i t2 m ;
GENERIC: g ( a -- b )
GENERIC: g ( a -- b ) ;
M: i g drop i ;
M: t4 g drop t4 ;

4
core/classes/maybe/maybe-tests.factor
View File

@ -46,7 +46,7 @@ UNION: ?integer-float maybe{ integer } maybe{ float } ;
{ f } [ t ?integer-float instance? ] unit-test
TUPLE: foo ;
GENERIC: lol ( obj -- string )
GENERIC: lol ( obj -- string ) ;
M: maybe{ foo } lol drop "lol" ;
{ "lol" } [ foo new lol ] unit-test
@ -54,7 +54,7 @@ M: maybe{ foo } lol drop "lol" ;
[ 3 lol ] [ no-method? ] must-fail-with
TUPLE: foo2 a ;
GENERIC: lol2 ( obj -- string )
GENERIC: lol2 ( obj -- string ) ;
M: maybe{ foo } lol2 drop "lol2" ;
M: f lol2 drop "lol22" ;

8
core/classes/mixin/mixin-tests.factor
View File

@ -15,7 +15,7 @@ mixin: assoc-mixin
INSTANCE: hashtable assoc-mixin
GENERIC: collection-size ( x -- y )
GENERIC: collection-size ( x -- y ) ;
M: sequence-mixin collection-size length ;
@ -58,7 +58,7 @@ use: io.streams.string
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"GENERIC: mixin-forget-test-g ( x -- y ) ;"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
@ -73,7 +73,7 @@ use: io.streams.string
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"GENERIC: mixin-forget-test-g ( x -- y ) ;"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
@ -133,7 +133,7 @@ mixin: metaclass-change-mixin
TUPLE: metaclass-change ;
INSTANCE: metaclass-change metaclass-change-mixin
GENERIC: metaclass-change-generic ( a -- b )
GENERIC: metaclass-change-generic ( a -- b ) ;
M: metaclass-change-mixin metaclass-change-generic ;

2
core/classes/mixin/mixin.factor
View File

@ -68,7 +68,7 @@ ERROR: check-mixin-class-error class ;
PRIVATE>
GENERIC# add-mixin-instance 1 ( class mixin -- )
GENERIC# add-mixin-instance 1 ( class mixin -- ) ;
M: class add-mixin-instance
[ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;

8
core/classes/predicate/predicate-tests.factor
View File

@ -12,7 +12,7 @@ PREDICATE: positive < integer 0 > ;
{ f } [ negative negative class< ] unit-test
{ f } [ positive negative class< ] unit-test
GENERIC: abs ( n -- n )
GENERIC: abs ( n -- n ) ;
M: integer abs ;
M: negative abs -1 * ;
M: positive abs ;
@ -27,7 +27,7 @@ TUPLE: tuple-b < tuple-a ;
PREDICATE: tuple-c < tuple-b slot>> ;
GENERIC: ptest ( tuple -- x )
GENERIC: ptest ( tuple -- x ) ;
M: tuple-a ptest drop tuple-a ;
M: tuple-c ptest drop tuple-c ;
@ -36,7 +36,7 @@ M: tuple-c ptest drop tuple-c ;
PREDICATE: tuple-d < tuple-a slot>> ;
GENERIC: ptest' ( tuple -- x )
GENERIC: ptest' ( tuple -- x ) ;
M: tuple-a ptest' drop tuple-a ;
M: tuple-d ptest' drop tuple-d ;
@ -61,7 +61,7 @@ UNION: u tup ;
{ } [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
! Changing the metaclass of the predicate superclass should work
GENERIC: change-meta-test ( a -- b )
GENERIC: change-meta-test ( a -- b ) ;
TUPLE: change-meta-test-class length ;

2
core/classes/predicate/predicate.factor
View File

@ -9,7 +9,7 @@ PREDICATE: predicate-class < class
<PRIVATE
GENERIC: predicate-quot ( class -- quot )
GENERIC: predicate-quot ( class -- quot ) ;
M: predicate-class predicate-quot
[

2
core/classes/singleton/singleton-tests.factor
View File

@ -4,7 +4,7 @@ in: classes.singleton.tests
{ } [ SINGLETON: bzzt ] unit-test
{ t } [ bzzt bzzt? ] unit-test
{ t } [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
GENERIC: zammo ( obj -- str ) ;
{ } [ M: bzzt zammo drop "yes!" ; ] unit-test
{ "yes!" } [ bzzt zammo ] unit-test
{ } [ SINGLETON: omg ] unit-test

2
core/classes/tuple/parser/parser.factor
View File

@ -91,7 +91,7 @@ ERROR: bad-slot-name class slot ;
: parse-slot-values ( class slots -- values )
[ (parse-slot-values) ] { } make ;
GENERIC# boa>object 1 ( class slots -- tuple )
GENERIC# boa>object 1 ( class slots -- tuple ) ;
M: tuple-class boa>object
swap slots>tuple ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -129,8 +129,8 @@ ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimeter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
{ $code
"USING: accessors kernel math math.constants math.functions ;"
"GENERIC: area ( shape -- n )"
"GENERIC: perimeter ( shape -- n )"
"GENERIC: area ( shape -- n ) ;"
"GENERIC: perimeter ( shape -- n ) ;"
""
"TUPLE: shape ;"
""

16
core/classes/tuple/tuple-tests.factor
View File

@ -74,7 +74,7 @@ C: <predicate-test> predicate-test
PREDICATE: silly-pred < tuple
class-of \ rect = ;
GENERIC: area ( obj -- n )
GENERIC: area ( obj -- n ) ;
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
@ -102,7 +102,7 @@ TUPLE: size-test a b c d ;
size-test tuple-layout second =
] unit-test
GENERIC: <yo-momma> ( a -- b )
GENERIC: <yo-momma> ( a -- b ) ;
TUPLE: yo-momma ;
@ -126,7 +126,7 @@ TUPLE: loc-recording ;
TUPLE: forget-robustness ;
GENERIC: forget-robustness-generic ( a -- b )
GENERIC: forget-robustness-generic ( a -- b ) ;
M: forget-robustness forget-robustness-generic ;
@ -139,8 +139,8 @@ M: integer forget-robustness-generic ;
] with-compilation-unit
! rapido found this one
GENERIC# m1 0 ( s n -- n )
GENERIC# m2 1 ( s n -- v )
GENERIC# m1 0 ( s n -- n ) ;
GENERIC# m2 1 ( s n -- v ) ;
TUPLE: t1 ;
@ -168,7 +168,7 @@ C: <t4> t4
{ 1 } [ <t4> 1 m2 ] unit-test
! another combination issue
GENERIC: silly ( obj -- obj obj )
GENERIC: silly ( obj -- obj obj ) ;
UNION: my-union slice repetition column array vector reversed ;
@ -488,7 +488,7 @@ must-fail-with
{ t } [ "z" accessor-exists? ] unit-test
{ [ ] } [
"IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
"IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b ) ;"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
@ -503,7 +503,7 @@ TUPLE: another-forget-accessors-test ;
{ [ ] } [
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b ) ;"
<string-reader>
"another-forget-accessors-test" parse-stream
] unit-test

8
core/classes/tuple/tuple.factor
View File

@ -93,7 +93,7 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple-slots copy-tuple-slots ;
GENERIC: slots>tuple ( seq class -- tuple )
GENERIC: slots>tuple ( seq class -- tuple ) ;
M: tuple-class slots>tuple ( seq class -- tuple )
check-slots pad-slots
@ -120,7 +120,7 @@ ERROR: bad-superclass class ;
] [ 2drop f ] if
] [ 2drop f ] if ; inline
GENERIC: final-class? ( object -- ? )
GENERIC: final-class? ( object -- ? ) ;
M: tuple-class final-class? "final" word-prop ;
@ -277,7 +277,7 @@ M: tuple-class update-class
dup final-class? [ bad-superclass ] when
dup class? [ bad-superclass ] unless drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
GENERIC# (define-tuple-class) 2 ( class superclass slots -- ) ;
: thrower-effect ( slots -- effect )
[ name>> ] map { "*" } <effect> ;
@ -303,7 +303,7 @@ PRIVATE>
over prepare-slots
(define-tuple-class) ;
GENERIC: make-final ( class -- )
GENERIC: make-final ( class -- ) ;
M: tuple-class make-final
[ dup class-usage ?metaclass-changed ]

6
core/classes/union/union-tests.factor
View File

@ -15,7 +15,7 @@ UNION: bah fixnum alien ;
! Test redefinition of classes
UNION: union-1 fixnum float ;
GENERIC: generic-update-test ( x -- y )
GENERIC: generic-update-test ( x -- y ) ;
M: union-1 generic-update-test drop "union-1" ;
@ -37,7 +37,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ -7 generic-update-test ] must-fail
! Empty unions were causing problems
GENERIC: empty-union-test ( obj -- obj )
GENERIC: empty-union-test ( obj -- obj ) ;
UNION: empty-union-1 ;
@ -77,7 +77,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
{ f } [ "foo?" "classes.union.tests" lookup-word predicate? ] unit-test
GENERIC: test-generic ( x -- y )
GENERIC: test-generic ( x -- y ) ;
TUPLE: a-tuple ;

4
core/classes/union/union.factor
View File

@ -11,7 +11,7 @@ PREDICATE: union-class < class
<PRIVATE
GENERIC: union-of-builtins? ( class -- ? )
GENERIC: union-of-builtins? ( class -- ? ) ;
M: builtin-class union-of-builtins? drop t ;
@ -55,7 +55,7 @@ M: union-class update-class define-union-predicate ;
ERROR: cannot-reference-self class members ;
GENERIC: classes-contained-by ( obj -- members )
GENERIC: classes-contained-by ( obj -- members ) ;
M: union-class classes-contained-by ( union -- members )
"members" word-prop [ f ] when-empty ;

2
core/compiler/units/units-tests.factor
View File

@ -60,7 +60,7 @@ observer remove-definition-observer
! Make sure that non-optimized calls to a generic word which
! hasn't been compiled yet work properly
GENERIC: uncompiled-generic-test ( a -- b )
GENERIC: uncompiled-generic-test ( a -- b ) ;
M: integer uncompiled-generic-test 1 + ;

12
core/compiler/units/units.factor
View File

@ -44,7 +44,7 @@ PRIVATE>
symbol: compiler-impl
HOOK: update-call-sites compiler-impl ( class generic -- words )
HOOK: update-call-sites compiler-impl ( class generic -- words ) ;
: changed-call-sites ( class generic -- )
update-call-sites [ changed-definition ] each ;
@ -58,11 +58,11 @@ M: generic update-generic ( class generic -- )
M: sequence update-methods ( class seq -- )
implementors [ update-generic ] with each ;
HOOK: recompile compiler-impl ( words -- alist )
HOOK: recompile compiler-impl ( words -- alist ) ;
HOOK: to-recompile compiler-impl ( -- words )
HOOK: to-recompile compiler-impl ( -- words ) ;
HOOK: process-forgotten-words compiler-impl ( words -- )
HOOK: process-forgotten-words compiler-impl ( words -- ) ;
: compile ( words -- )
recompile t f modify-code-heap ;
@ -86,7 +86,7 @@ M: f process-forgotten-words drop ;
symbol: definition-observers
GENERIC: definitions-changed ( set obj -- )
GENERIC: definitions-changed ( set obj -- ) ;
[ V{ } clone definition-observers set-global ]
"compiler.units" add-startup-hook
@ -110,7 +110,7 @@ GENERIC: definitions-changed ( set obj -- )
! inline caching
: effect-counter ( -- n ) REDEFINITION-COUNTER special-object ; inline
GENERIC: always-bump-effect-counter? ( defspec -- ? )
GENERIC: always-bump-effect-counter? ( defspec -- ? ) ;
M: object always-bump-effect-counter? drop f ;

4
core/continuations/continuations.factor
View File

@ -105,7 +105,7 @@ symbol: return-continuation
: return ( -- * )
return-continuation get continue ;
GENERIC: compute-restarts ( error -- seq )
GENERIC: compute-restarts ( error -- seq ) ;
<PRIVATE
@ -115,7 +115,7 @@ GENERIC: compute-restarts ( error -- seq )
PRIVATE>
GENERIC: error-in-thread ( error thread -- * )
GENERIC: error-in-thread ( error thread -- * ) ;
symbol: thread-error-hook ! ( error thread -- * )

502
core/cpu/architecture/architecture.factor
View File

@ -152,9 +152,9 @@ CONSTANT: reg-classes { int-regs float-regs }
! On x86, vectors and floats are stored in the same register bank
! On PowerPC they are distinct
HOOK: vector-regs cpu ( -- reg-class )
HOOK: vector-regs cpu ( -- reg-class ) ;
GENERIC: reg-class-of ( rep -- reg-class )
GENERIC: reg-class-of ( rep -- reg-class ) ;
M: tagged-rep reg-class-of drop int-regs ;
M: int-rep reg-class-of drop int-regs ;
@ -163,7 +163,7 @@ M: double-rep reg-class-of drop float-regs ;
M: vector-rep reg-class-of drop vector-regs ;
M: scalar-rep reg-class-of drop vector-regs ;
GENERIC: rep-size ( rep -- n ) foldable
GENERIC: rep-size ( rep -- n ) ; foldable
M: tagged-rep rep-size drop cell ;
M: int-rep rep-size drop cell ;
@ -179,7 +179,7 @@ M: uint-scalar-rep rep-size drop 4 ;
M: longlong-scalar-rep rep-size drop 8 ;
M: ulonglong-scalar-rep rep-size drop 8 ;
GENERIC: rep-length ( rep -- n ) foldable
GENERIC: rep-length ( rep -- n ) ; foldable
M: char-16-rep rep-length drop 16 ;
M: uchar-16-rep rep-length drop 16 ;
@ -192,11 +192,11 @@ M: ulonglong-2-rep rep-length drop 2 ;
M: float-4-rep rep-length drop 4 ;
M: double-2-rep rep-length drop 2 ;
GENERIC: rep-component-type ( rep -- n )
GENERIC: rep-component-type ( rep -- n ) ;
! Methods defined in alien.c-types
GENERIC: scalar-rep-of ( rep -- rep' )
GENERIC: scalar-rep-of ( rep -- rep' ) ;
M: float-4-rep scalar-rep-of drop float-rep ;
M: double-2-rep scalar-rep-of drop double-rep ;
@ -209,207 +209,207 @@ M: uint-4-rep scalar-rep-of drop uint-scalar-rep ;
M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ;
M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
HOOK: machine-registers cpu ( -- assoc )
HOOK: machine-registers cpu ( -- assoc ) ;
! Callbacks are not allowed to clobber this
HOOK: frame-reg cpu ( -- reg )
HOOK: frame-reg cpu ( -- reg ) ;
HOOK: vm-stack-space cpu ( -- n )
HOOK: vm-stack-space cpu ( -- n ) ;
M: object vm-stack-space 0 ;
HOOK: complex-addressing? cpu ( -- ? )
HOOK: complex-addressing? cpu ( -- ? ) ;
HOOK: gc-root-offset cpu ( spill-slot -- n )
HOOK: gc-root-offset cpu ( spill-slot -- n ) ;
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-float cpu ( reg val -- )
HOOK: %load-double cpu ( reg val -- )
HOOK: %load-vector cpu ( reg val rep -- )
HOOK: %load-immediate cpu ( reg val -- ) ;
HOOK: %load-reference cpu ( reg obj -- ) ;
HOOK: %load-float cpu ( reg val -- ) ;
HOOK: %load-double cpu ( reg val -- ) ;
HOOK: %load-vector cpu ( reg val rep -- ) ;
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
HOOK: %replace-imm cpu ( src loc -- )
HOOK: %clear cpu ( loc -- )
HOOK: %inc cpu ( loc -- )
HOOK: %peek cpu ( vreg loc -- ) ;
HOOK: %replace cpu ( vreg loc -- ) ;
HOOK: %replace-imm cpu ( src loc -- ) ;
HOOK: %clear cpu ( loc -- ) ;
HOOK: %inc cpu ( loc -- ) ;
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
HOOK: stack-frame-size cpu ( stack-frame -- n ) ;
HOOK: %call cpu ( word -- ) ;
HOOK: %jump cpu ( word -- ) ;
HOOK: %jump-label cpu ( label -- ) ;
HOOK: %return cpu ( -- ) ;
HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch cpu ( src temp -- ) ;
HOOK: %slot cpu ( dst obj slot scale tag -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
HOOK: %set-slot cpu ( src obj slot scale tag -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %slot cpu ( dst obj slot scale tag -- ) ;
HOOK: %slot-imm cpu ( dst obj slot tag -- ) ;
HOOK: %set-slot cpu ( src obj slot scale tag -- ) ;
HOOK: %set-slot-imm cpu ( src obj slot tag -- ) ;
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
HOOK: %sub cpu ( dst src1 src2 -- )
HOOK: %sub-imm cpu ( dst src1 src2 -- )
HOOK: %mul cpu ( dst src1 src2 -- )
HOOK: %mul-imm cpu ( dst src1 src2 -- )
HOOK: %and cpu ( dst src1 src2 -- )
HOOK: %and-imm cpu ( dst src1 src2 -- )
HOOK: %or cpu ( dst src1 src2 -- )
HOOK: %or-imm cpu ( dst src1 src2 -- )
HOOK: %xor cpu ( dst src1 src2 -- )
HOOK: %xor-imm cpu ( dst src1 src2 -- )
HOOK: %shl cpu ( dst src1 src2 -- )
HOOK: %shl-imm cpu ( dst src1 src2 -- )
HOOK: %shr cpu ( dst src1 src2 -- )
HOOK: %shr-imm cpu ( dst src1 src2 -- )
HOOK: %sar cpu ( dst src1 src2 -- )
HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %min cpu ( dst src1 src2 -- )
HOOK: %max cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %neg cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %bit-count cpu ( dst src -- )
HOOK: %bit-test cpu ( dst src1 src2 temp -- )
HOOK: %add cpu ( dst src1 src2 -- ) ;
HOOK: %add-imm cpu ( dst src1 src2 -- ) ;
HOOK: %sub cpu ( dst src1 src2 -- ) ;
HOOK: %sub-imm cpu ( dst src1 src2 -- ) ;
HOOK: %mul cpu ( dst src1 src2 -- ) ;
HOOK: %mul-imm cpu ( dst src1 src2 -- ) ;
HOOK: %and cpu ( dst src1 src2 -- ) ;
HOOK: %and-imm cpu ( dst src1 src2 -- ) ;
HOOK: %or cpu ( dst src1 src2 -- ) ;
HOOK: %or-imm cpu ( dst src1 src2 -- ) ;
HOOK: %xor cpu ( dst src1 src2 -- ) ;
HOOK: %xor-imm cpu ( dst src1 src2 -- ) ;
HOOK: %shl cpu ( dst src1 src2 -- ) ;
HOOK: %shl-imm cpu ( dst src1 src2 -- ) ;
HOOK: %shr cpu ( dst src1 src2 -- ) ;
HOOK: %shr-imm cpu ( dst src1 src2 -- ) ;
HOOK: %sar cpu ( dst src1 src2 -- ) ;
HOOK: %sar-imm cpu ( dst src1 src2 -- ) ;
HOOK: %min cpu ( dst src1 src2 -- ) ;
HOOK: %max cpu ( dst src1 src2 -- ) ;
HOOK: %not cpu ( dst src -- ) ;
HOOK: %neg cpu ( dst src -- ) ;
HOOK: %log2 cpu ( dst src -- ) ;
HOOK: %bit-count cpu ( dst src -- ) ;
HOOK: %bit-test cpu ( dst src1 src2 temp -- ) ;
HOOK: %copy cpu ( dst src rep -- )
HOOK: %copy cpu ( dst src rep -- ) ;
: %tagged>integer ( dst src -- ) int-rep %copy ;
HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- ) ;
HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- ) ;
HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- ) ;
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-float cpu ( dst src1 src2 -- )
HOOK: %min-float cpu ( dst src1 src2 -- )
HOOK: %max-float cpu ( dst src1 src2 -- )
HOOK: %sqrt cpu ( dst src -- )
HOOK: %add-float cpu ( dst src1 src2 -- ) ;
HOOK: %sub-float cpu ( dst src1 src2 -- ) ;
HOOK: %mul-float cpu ( dst src1 src2 -- ) ;
HOOK: %div-float cpu ( dst src1 src2 -- ) ;
HOOK: %min-float cpu ( dst src1 src2 -- ) ;
HOOK: %max-float cpu ( dst src1 src2 -- ) ;
HOOK: %sqrt cpu ( dst src -- ) ;
HOOK: %single>double-float cpu ( dst src -- )
HOOK: %double>single-float cpu ( dst src -- )
HOOK: %single>double-float cpu ( dst src -- ) ;
HOOK: %double>single-float cpu ( dst src -- ) ;
HOOK: integer-float-needs-stack-frame? cpu ( -- ? )
HOOK: integer-float-needs-stack-frame? cpu ( -- ? ) ;
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- ) ;
HOOK: %float>integer cpu ( dst src -- ) ;
HOOK: %zero-vector cpu ( dst rep -- )
HOOK: %fill-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-int-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %gather-int-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %select-vector cpu ( dst src n rep -- )
HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
HOOK: %shuffle-vector-imm cpu ( dst src shuffle rep -- )
HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- )
HOOK: %tail>head-vector cpu ( dst src rep -- )
HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
HOOK: %float-pack-vector cpu ( dst src rep -- )
HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- )
HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- )
HOOK: %unpack-vector-head cpu ( dst src rep -- )
HOOK: %unpack-vector-tail cpu ( dst src rep -- )
HOOK: %integer>float-vector cpu ( dst src rep -- )
HOOK: %float>integer-vector cpu ( dst src rep -- )
HOOK: %compare-vector cpu ( dst src1 src2 rep cc -- )
HOOK: %move-vector-mask cpu ( dst src rep -- )
HOOK: %test-vector cpu ( dst src1 temp rep vcc -- )
HOOK: %test-vector-branch cpu ( label src1 temp rep vcc -- )
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-high-vector cpu ( dst src1 src2 rep -- )
HOOK: %mul-horizontal-add-vector cpu ( dst src1 src2 rep -- )
HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
HOOK: %avg-vector cpu ( dst src1 src2 rep -- )
HOOK: %dot-vector cpu ( dst src1 src2 rep -- )
HOOK: %sad-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src1 src2 rep -- )
HOOK: %horizontal-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %abs-vector cpu ( dst src rep -- )
HOOK: %and-vector cpu ( dst src1 src2 rep -- )
HOOK: %andn-vector cpu ( dst src1 src2 rep -- )
HOOK: %or-vector cpu ( dst src1 src2 rep -- )
HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
HOOK: %not-vector cpu ( dst src rep -- )
HOOK: %shl-vector cpu ( dst src1 src2 rep -- )
HOOK: %shr-vector cpu ( dst src1 src2 rep -- )
HOOK: %shl-vector-imm cpu ( dst src1 src2 rep -- )
HOOK: %shr-vector-imm cpu ( dst src1 src2 rep -- )
HOOK: %horizontal-shl-vector-imm cpu ( dst src1 src2 rep -- )
HOOK: %horizontal-shr-vector-imm cpu ( dst src1 src2 rep -- )
HOOK: %zero-vector cpu ( dst rep -- ) ;
HOOK: %fill-vector cpu ( dst rep -- ) ;
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- ) ;
HOOK: %gather-int-vector-2 cpu ( dst src1 src2 rep -- ) ;
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- ) ;
HOOK: %gather-int-vector-4 cpu ( dst src1 src2 src3 src4 rep -- ) ;
HOOK: %select-vector cpu ( dst src n rep -- ) ;
HOOK: %shuffle-vector cpu ( dst src shuffle rep -- ) ;
HOOK: %shuffle-vector-imm cpu ( dst src shuffle rep -- ) ;
HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- ) ;
HOOK: %tail>head-vector cpu ( dst src rep -- ) ;
HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- ) ;
HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- ) ;
HOOK: %float-pack-vector cpu ( dst src rep -- ) ;
HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %unpack-vector-head cpu ( dst src rep -- ) ;
HOOK: %unpack-vector-tail cpu ( dst src rep -- ) ;
HOOK: %integer>float-vector cpu ( dst src rep -- ) ;
HOOK: %float>integer-vector cpu ( dst src rep -- ) ;
HOOK: %compare-vector cpu ( dst src1 src2 rep cc -- ) ;
HOOK: %move-vector-mask cpu ( dst src rep -- ) ;
HOOK: %test-vector cpu ( dst src1 temp rep vcc -- ) ;
HOOK: %test-vector-branch cpu ( label src1 temp rep vcc -- ) ;
HOOK: %add-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %sub-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %mul-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %mul-high-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %mul-horizontal-add-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %div-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %min-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %max-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %avg-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %dot-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %sad-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %sqrt-vector cpu ( dst src rep -- ) ;
HOOK: %horizontal-add-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %horizontal-sub-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %abs-vector cpu ( dst src rep -- ) ;
HOOK: %and-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %andn-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %or-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %xor-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %not-vector cpu ( dst src rep -- ) ;
HOOK: %shl-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %shr-vector cpu ( dst src1 src2 rep -- ) ;
HOOK: %shl-vector-imm cpu ( dst src1 src2 rep -- ) ;
HOOK: %shr-vector-imm cpu ( dst src1 src2 rep -- ) ;
HOOK: %horizontal-shl-vector-imm cpu ( dst src1 src2 rep -- ) ;
HOOK: %horizontal-shr-vector-imm cpu ( dst src1 src2 rep -- ) ;
HOOK: %integer>scalar cpu ( dst src rep -- )
HOOK: %scalar>integer cpu ( dst src rep -- )
HOOK: %vector>scalar cpu ( dst src rep -- )
HOOK: %scalar>vector cpu ( dst src rep -- )
HOOK: %integer>scalar cpu ( dst src rep -- ) ;
HOOK: %scalar>integer cpu ( dst src rep -- ) ;
HOOK: %vector>scalar cpu ( dst src rep -- ) ;
HOOK: %scalar>vector cpu ( dst src rep -- ) ;
HOOK: %zero-vector-reps cpu ( -- reps )
HOOK: %fill-vector-reps cpu ( -- reps )
HOOK: %gather-vector-2-reps cpu ( -- reps )
HOOK: %gather-int-vector-2-reps cpu ( -- reps )
HOOK: %gather-vector-4-reps cpu ( -- reps )
HOOK: %gather-int-vector-4-reps cpu ( -- reps )
HOOK: %select-vector-reps cpu ( -- reps )
HOOK: %alien-vector-reps cpu ( -- reps )
HOOK: %shuffle-vector-reps cpu ( -- reps )
HOOK: %shuffle-vector-imm-reps cpu ( -- reps )
HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps )
HOOK: %merge-vector-reps cpu ( -- reps )
HOOK: %float-pack-vector-reps cpu ( -- reps )
HOOK: %signed-pack-vector-reps cpu ( -- reps )
HOOK: %unsigned-pack-vector-reps cpu ( -- reps )
HOOK: %unpack-vector-head-reps cpu ( -- reps )
HOOK: %unpack-vector-tail-reps cpu ( -- reps )
HOOK: %integer>float-vector-reps cpu ( -- reps )
HOOK: %float>integer-vector-reps cpu ( -- reps )
HOOK: %compare-vector-reps cpu ( cc -- reps )
HOOK: %compare-vector-ccs cpu ( rep cc -- {cc,swap?}s not? )
HOOK: %move-vector-mask-reps cpu ( -- reps )
HOOK: %test-vector-reps cpu ( -- reps )
HOOK: %add-vector-reps cpu ( -- reps )
HOOK: %saturated-add-vector-reps cpu ( -- reps )
HOOK: %add-sub-vector-reps cpu ( -- reps )
HOOK: %sub-vector-reps cpu ( -- reps )
HOOK: %saturated-sub-vector-reps cpu ( -- reps )
HOOK: %mul-vector-reps cpu ( -- reps )
HOOK: %mul-high-vector-reps cpu ( -- reps )
HOOK: %mul-horizontal-add-vector-reps cpu ( -- reps )
HOOK: %saturated-mul-vector-reps cpu ( -- reps )
HOOK: %div-vector-reps cpu ( -- reps )
HOOK: %min-vector-reps cpu ( -- reps )
HOOK: %max-vector-reps cpu ( -- reps )
HOOK: %avg-vector-reps cpu ( -- reps )
HOOK: %dot-vector-reps cpu ( -- reps )
HOOK: %sad-vector-reps cpu ( -- reps )
HOOK: %sqrt-vector-reps cpu ( -- reps )
HOOK: %horizontal-add-vector-reps cpu ( -- reps )
HOOK: %horizontal-sub-vector-reps cpu ( -- reps )
HOOK: %abs-vector-reps cpu ( -- reps )
HOOK: %and-vector-reps cpu ( -- reps )
HOOK: %andn-vector-reps cpu ( -- reps )
HOOK: %or-vector-reps cpu ( -- reps )
HOOK: %xor-vector-reps cpu ( -- reps )
HOOK: %not-vector-reps cpu ( -- reps )
HOOK: %shl-vector-reps cpu ( -- reps )
HOOK: %shr-vector-reps cpu ( -- reps )
HOOK: %shl-vector-imm-reps cpu ( -- reps )
HOOK: %shr-vector-imm-reps cpu ( -- reps )
HOOK: %horizontal-shl-vector-imm-reps cpu ( -- reps )
HOOK: %horizontal-shr-vector-imm-reps cpu ( -- reps )
HOOK: %zero-vector-reps cpu ( -- reps ) ;
HOOK: %fill-vector-reps cpu ( -- reps ) ;
HOOK: %gather-vector-2-reps cpu ( -- reps ) ;
HOOK: %gather-int-vector-2-reps cpu ( -- reps ) ;
HOOK: %gather-vector-4-reps cpu ( -- reps ) ;
HOOK: %gather-int-vector-4-reps cpu ( -- reps ) ;
HOOK: %select-vector-reps cpu ( -- reps ) ;
HOOK: %alien-vector-reps cpu ( -- reps ) ;
HOOK: %shuffle-vector-reps cpu ( -- reps ) ;
HOOK: %shuffle-vector-imm-reps cpu ( -- reps ) ;
HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps ) ;
HOOK: %merge-vector-reps cpu ( -- reps ) ;
HOOK: %float-pack-vector-reps cpu ( -- reps ) ;
HOOK: %signed-pack-vector-reps cpu ( -- reps ) ;
HOOK: %unsigned-pack-vector-reps cpu ( -- reps ) ;
HOOK: %unpack-vector-head-reps cpu ( -- reps ) ;
HOOK: %unpack-vector-tail-reps cpu ( -- reps ) ;
HOOK: %integer>float-vector-reps cpu ( -- reps ) ;
HOOK: %float>integer-vector-reps cpu ( -- reps ) ;
HOOK: %compare-vector-reps cpu ( cc -- reps ) ;
HOOK: %compare-vector-ccs cpu ( rep cc -- {cc,swap?}s not? ) ;
HOOK: %move-vector-mask-reps cpu ( -- reps ) ;
HOOK: %test-vector-reps cpu ( -- reps ) ;
HOOK: %add-vector-reps cpu ( -- reps ) ;
HOOK: %saturated-add-vector-reps cpu ( -- reps ) ;
HOOK: %add-sub-vector-reps cpu ( -- reps ) ;
HOOK: %sub-vector-reps cpu ( -- reps ) ;
HOOK: %saturated-sub-vector-reps cpu ( -- reps ) ;
HOOK: %mul-vector-reps cpu ( -- reps ) ;
HOOK: %mul-high-vector-reps cpu ( -- reps ) ;
HOOK: %mul-horizontal-add-vector-reps cpu ( -- reps ) ;
HOOK: %saturated-mul-vector-reps cpu ( -- reps ) ;
HOOK: %div-vector-reps cpu ( -- reps ) ;
HOOK: %min-vector-reps cpu ( -- reps ) ;
HOOK: %max-vector-reps cpu ( -- reps ) ;
HOOK: %avg-vector-reps cpu ( -- reps ) ;
HOOK: %dot-vector-reps cpu ( -- reps ) ;
HOOK: %sad-vector-reps cpu ( -- reps ) ;
HOOK: %sqrt-vector-reps cpu ( -- reps ) ;
HOOK: %horizontal-add-vector-reps cpu ( -- reps ) ;
HOOK: %horizontal-sub-vector-reps cpu ( -- reps ) ;
HOOK: %abs-vector-reps cpu ( -- reps ) ;
HOOK: %and-vector-reps cpu ( -- reps ) ;
HOOK: %andn-vector-reps cpu ( -- reps ) ;
HOOK: %or-vector-reps cpu ( -- reps ) ;
HOOK: %xor-vector-reps cpu ( -- reps ) ;
HOOK: %not-vector-reps cpu ( -- reps ) ;
HOOK: %shl-vector-reps cpu ( -- reps ) ;
HOOK: %shr-vector-reps cpu ( -- reps ) ;
HOOK: %shl-vector-imm-reps cpu ( -- reps ) ;
HOOK: %shr-vector-imm-reps cpu ( -- reps ) ;
HOOK: %horizontal-shl-vector-imm-reps cpu ( -- reps ) ;
HOOK: %horizontal-shr-vector-imm-reps cpu ( -- reps ) ;
M: object %zero-vector-reps { } ;
M: object %fill-vector-reps { } ;
@ -464,76 +464,76 @@ ALIAS: %merge-vector-head-reps %merge-vector-reps
ALIAS: %merge-vector-tail-reps %merge-vector-reps
ALIAS: %tail>head-vector-reps %unpack-vector-head-reps
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
HOOK: %unbox-alien cpu ( dst src -- ) ;
HOOK: %unbox-any-c-ptr cpu ( dst src -- ) ;
HOOK: %box-alien cpu ( dst src temp -- ) ;
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- ) ;
HOOK: %convert-integer cpu ( dst src c-type -- )
HOOK: %convert-integer cpu ( dst src c-type -- ) ;
HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )
HOOK: %store-memory-imm cpu ( value base offset rep c-type -- )
HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- ) ;
HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- ) ;
HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- ) ;
HOOK: %store-memory-imm cpu ( value base offset rep c-type -- ) ;
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst offset -- )
HOOK: %set-vm-field cpu ( src offset -- )
HOOK: %alien-global cpu ( dst symbol library -- ) ;
HOOK: %vm-field cpu ( dst offset -- ) ;
HOOK: %set-vm-field cpu ( src offset -- ) ;
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
HOOK: %allot cpu ( dst size class temp -- ) ;
HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- ) ;
HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- ) ;
! GC checks
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
HOOK: %call-gc cpu ( gc-map -- )
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- ) ;
HOOK: %call-gc cpu ( gc-map -- ) ;
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %prologue cpu ( n -- ) ;
HOOK: %epilogue cpu ( n -- ) ;
HOOK: %safepoint cpu ( -- )
HOOK: %safepoint cpu ( -- ) ;
HOOK: test-instruction? cpu ( -- ? )
HOOK: test-instruction? cpu ( -- ? ) ;
M: object test-instruction? f ;
HOOK: %compare cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-integer-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %test cpu ( dst src1 src2 cc temp -- )
HOOK: %test-imm cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-float-ordered cpu ( dst src1 src2 cc temp -- )
HOOK: %compare-float-unordered cpu ( dst src1 src2 cc temp -- )
HOOK: %compare cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %compare-imm cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %compare-integer-imm cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %test cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %test-imm cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %compare-float-ordered cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %compare-float-unordered cpu ( dst src1 src2 cc temp -- ) ;
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %test-branch cpu ( label cc src1 src2 -- )
HOOK: %test-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %test-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %test-imm-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- ) ;
HOOK: %spill cpu ( src rep dst -- )
HOOK: %reload cpu ( dst rep src -- )
HOOK: %spill cpu ( src rep dst -- ) ;
HOOK: %reload cpu ( dst rep src -- ) ;
HOOK: %loop-entry cpu ( -- )
HOOK: %loop-entry cpu ( -- ) ;
HOOK: fused-unboxing? cpu ( -- ? )
HOOK: fused-unboxing? cpu ( -- ? ) ;
HOOK: immediate-arithmetic? cpu ( n -- ? )
HOOK: immediate-arithmetic? cpu ( n -- ? ) ;
! Can this value be an immediate operand for %and-imm, %or-imm,
! or %xor-imm?
HOOK: immediate-bitwise? cpu ( n -- ? )
HOOK: immediate-bitwise? cpu ( n -- ? ) ;
! Can this value be an immediate operand for %compare-imm or
! %compare-imm-branch?
HOOK: immediate-comparand? cpu ( n -- ? )
HOOK: immediate-comparand? cpu ( n -- ? ) ;
! Can this value be an immediate operand for %replace-imm?
HOOK: immediate-store? cpu ( obj -- ? )
HOOK: immediate-store? cpu ( obj -- ? ) ;
M: object immediate-comparand? ( n -- ? )
{
@ -547,66 +547,66 @@ M: object immediate-comparand? ( n -- ? )
! FFI stuff
HOOK: return-regs cpu ( -- regs )
HOOK: return-regs cpu ( -- regs ) ;
HOOK: param-regs cpu ( abi -- regs )
HOOK: param-regs cpu ( abi -- regs ) ;
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
HOOK: return-struct-in-registers? cpu ( c-type -- ? ) ;
! Do we pass this struct by value or hidden reference?
HOOK: value-struct? cpu ( c-type -- ? )
HOOK: value-struct? cpu ( c-type -- ? ) ;
! If t, all parameters are shadowed by dummy stack parameters
HOOK: dummy-stack-params? cpu ( -- ? )
HOOK: dummy-stack-params? cpu ( -- ? ) ;
! If t, all FP parameters are shadowed by dummy int parameters
HOOK: dummy-int-params? cpu ( -- ? )
HOOK: dummy-int-params? cpu ( -- ? ) ;
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
HOOK: dummy-fp-params? cpu ( -- ? ) ;
! If t, long longs are never passed in param regs
HOOK: long-long-on-stack? cpu ( -- ? )
HOOK: long-long-on-stack? cpu ( -- ? ) ;
! If t, long longs are aligned on an odd register. On Linux
! 32-bit PPC, long longs are 8-byte aligned but passed in
! registers so they need to be aligned on an odd numbered
! (r3, r5, etc) register.
HOOK: long-long-odd-register? cpu ( -- ? )
HOOK: long-long-odd-register? cpu ( -- ? ) ;
! If t, floats are never passed in param regs
HOOK: float-on-stack? cpu ( -- ? )
HOOK: float-on-stack? cpu ( -- ? ) ;
! If t, put floats in the second word of a double word on the stack
HOOK: float-right-align-on-stack? cpu ( -- ? )
HOOK: float-right-align-on-stack? cpu ( -- ? ) ;
! If t, the struct return pointer is never passed in a param reg
HOOK: struct-return-on-stack? cpu ( -- ? )
HOOK: struct-return-on-stack? cpu ( -- ? ) ;
! Call a function to convert a tagged pointer into a value that
! can be passed to a C function, or returned from a callback
HOOK: %unbox cpu ( dst src func rep -- )
HOOK: %unbox cpu ( dst src func rep -- ) ;
HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- )
HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- ) ;
HOOK: %local-allot cpu ( dst size align offset -- )
HOOK: %local-allot cpu ( dst size align offset -- ) ;
HOOK: %box cpu ( dst src func rep gc-map -- )
HOOK: %box cpu ( dst src func rep gc-map -- ) ;
HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- ) ;
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- ) ;
HOOK: %c-invoke cpu ( symbols dll gc-map -- )
HOOK: %c-invoke cpu ( symbols dll gc-map -- ) ;
HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- )
HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- ) ;
HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- )
HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- ) ;
HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- ) ;
HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- ) ;
HOOK: %callback-outputs cpu ( reg-inputs -- )
HOOK: %callback-outputs cpu ( reg-inputs -- ) ;
HOOK: stack-cleanup cpu ( stack-size return abi -- n )
HOOK: stack-cleanup cpu ( stack-size return abi -- n ) ;

2
core/definitions/definitions-tests.factor
View File

@ -2,7 +2,7 @@ USING: arrays bit-arrays byte-arrays compiler.units definitions
tools.test ;
in: definitions.tests
GENERIC: some-generic ( a -- b )
GENERIC: some-generic ( a -- b ) ;
use: arrays

10
core/definitions/definitions.factor
View File

@ -29,13 +29,13 @@ symbol: new-words
: new-word ( word -- )
new-words get add-to-unit ;
GENERIC: where ( defspec -- loc )
GENERIC: where ( defspec -- loc ) ;
M: object where drop f ;
GENERIC: set-where ( loc defspec -- )
GENERIC: set-where ( loc defspec -- ) ;
GENERIC: forget* ( defspec -- )
GENERIC: forget* ( defspec -- ) ;
symbol: forgotten-definitions
@ -51,6 +51,6 @@ M: wrapper forget* wrapped>> forget ;
: forget-all ( definitions -- ) [ forget ] each ;
GENERIC: definer ( defspec -- start end )
GENERIC: definer ( defspec -- start end ) ;
GENERIC: definition ( defspec -- seq )
GENERIC: definition ( defspec -- seq ) ;

22
core/delegate/delegate-tests.factor
View File

@ -10,9 +10,9 @@ C: <hello> hello
TUPLE: goodbye these those ;
C: <goodbye> goodbye
GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
GENERIC# whoa 1 ( s t -- w )
GENERIC: foo ( x -- y ) ;
GENERIC: bar ( a -- b ) ;
GENERIC# whoa 1 ( s t -- w ) ;
PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
: hello-test ( hello/goodbye -- array )
@ -23,7 +23,7 @@ M: hello foo this>> ;
M: hello bar hello-test ;
M: hello whoa [ this>> ] dip + ;
GENERIC: bing ( c -- d )
GENERIC: bing ( c -- d ) ;
PROTOCOL: bee bing ;
CONSULT: hello goodbye those>> ;
M: hello bing hello-test ;
@ -41,13 +41,13 @@ M: hello bing hello-test ;
{ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" } [ [ baz see ] with-string-writer ] unit-test
GENERIC: one ( a -- b )
GENERIC: one ( a -- b ) ;
M: integer one ;
GENERIC: two ( a -- b )
GENERIC: two ( a -- b ) ;
M: integer two ;
GENERIC: three ( a -- b )
GENERIC: three ( a -- b ) ;
M: integer three ;
GENERIC: four ( a -- b )
GENERIC: four ( a -- b ) ;
M: integer four ;
PROTOCOL: alpha one two ;
@ -104,7 +104,7 @@ CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ;
a-read-only-slot>>
] unit-test
GENERIC: do-me ( x -- )
GENERIC: do-me ( x -- ) ;
M: f do-me drop ;
@ -209,8 +209,8 @@ DEFER: seq-delegate
key?
] unit-test
GENERIC: broadcastable ( x -- )
GENERIC: nonbroadcastable ( x -- y )
GENERIC: broadcastable ( x -- ) ;
GENERIC: nonbroadcastable ( x -- y ) ;
TUPLE: broadcaster targets ;

4
core/delegate/delegate.factor
View File

@ -17,7 +17,7 @@ ERROR: broadcast-words-must-have-no-outputs group ;
: protocol-consult ( protocol -- consulters )
"protocol-consult" word-prop ;
GENERIC: group-words ( group -- words )
GENERIC: group-words ( group -- words ) ;
M: standard-generic group-words
dup "combination" word-prop #>> 2array 1array ;
@ -62,7 +62,7 @@ PREDICATE: consult-method < method
M: consult-method reset-word
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
GENERIC# (consult-method-quot) 2 ( consultation quot word -- object ) ;
M: consultation (consult-method-quot)
'[ _ call _ execute ] nip ;

4
core/destructors/destructors.factor
View File

@ -30,14 +30,14 @@ continuation ;
: new-disposable ( class -- disposable )
new dup register-disposable ; inline
GENERIC: dispose* ( disposable -- )
GENERIC: dispose* ( disposable -- ) ;
ERROR: already-disposed disposable ;
: check-disposed ( disposable -- disposable )
dup disposed>> [ already-disposed ] when ; inline
GENERIC: dispose ( disposable -- )
GENERIC: dispose ( disposable -- ) ;
: unless-disposed ( disposable quot -- )
[ dup disposed>> [ drop ] ] dip if ; inline

6
core/effects/effects.factor
View File

@ -49,7 +49,7 @@ TUPLE: effect
[ [ terminated?>> ] same? ]
2tri and and ;
GENERIC: effect>string ( obj -- str )
GENERIC: effect>string ( obj -- str ) ;
M: string effect>string ;
M: object effect>string drop "object" ;
M: word effect>string name>> ;
@ -80,7 +80,7 @@ M: effect effect>string ( effect -- string )
")" %
] "" make ;
GENERIC: effect>type ( obj -- type )
GENERIC: effect>type ( obj -- type ) ;
M: object effect>type drop object ;
M: word effect>type ;
M: pair effect>type second-unsafe effect>type ;
@ -92,7 +92,7 @@ M: classoid effect>type ;
: effect-out-types ( effect -- input-types )
out>> [ effect>type ] map ;
GENERIC: stack-effect ( word -- effect/f )
GENERIC: stack-effect ( word -- effect/f ) ;
M: word stack-effect
dup "declared-effect" word-prop [ nip ] [

4
core/fry/fry.factor
View File

@ -10,7 +10,7 @@ in: fry
ERROR: >r/r>-in-fry-error ;
GENERIC: fry ( quot -- quot' )
GENERIC: fry ( quot -- quot' ) ;
<PRIVATE
@ -20,7 +20,7 @@ GENERIC: fry ( quot -- quot' )
PREDICATE: fry-specifier < word { _ @ } member-eq? ;
GENERIC: count-inputs ( quot -- n )
GENERIC: count-inputs ( quot -- n ) ;
M: callable count-inputs [ count-inputs ] map-sum ;
M: fry-specifier count-inputs drop 1 ;

6
core/generic/generic-docs.factor
View File

@ -9,7 +9,7 @@ ARTICLE: "method-order" "Method precedence"
$nl
"Here is an example:"
{ $code
"GENERIC: explain ( object -- )"
"GENERIC: explain ( object -- ) ;"
"M: object explain drop \"an object\" print ;"
"M: generic explain drop \"a generic word\" print ;"
"M: class explain drop \"a class word\" print ;"
@ -22,7 +22,7 @@ $nl
{ $subsections order } ;
ARTICLE: "generic-introspection" "Generic word introspection"
"In most cases, generic words and methods are defined at parse time with " { $link postpone: GENERIC: } " (or some other parsing word) and " { $link postpone: M: } "."
"In most cases, generic words and methods are defined at parse time with " { $link postpone: GENERIC: } " (or some other parsing word) ; and " { $link postpone: M: } "."
$nl
"Sometimes, generic words need to be inspected or defined at run time; words for performing these tasks are found in the " { $vocab-link "generic" } " vocabulary."
$nl
@ -186,7 +186,7 @@ HELP: no-next-method
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
"GENERIC: error-test ( object -- ) ;"
""
"M: number error-test 3 + call-next-method ;"
""

14
core/generic/generic.factor
View File

@ -7,9 +7,9 @@ sets words ;
in: generic
! Method combination protocol
GENERIC: perform-combination ( word combination -- )
GENERIC: perform-combination ( word combination -- ) ;
GENERIC: make-default-method ( generic combination -- method )
GENERIC: make-default-method ( generic combination -- method ) ;
PREDICATE: generic < word
"combination" word-prop >boolean ;
@ -63,7 +63,7 @@ PRIVATE>
[ nip ] [ nearest-class ] 2bi
[ swap ?lookup-method ] [ drop f ] if* ;
GENERIC: effective-method ( generic -- method )
GENERIC: effective-method ( generic -- method ) ;
\ effective-method t "no-compile" set-word-prop
@ -73,7 +73,7 @@ GENERIC: effective-method ( generic -- method )
: next-method ( class generic -- method/f )
[ next-method-class ] keep ?lookup-method ;
GENERIC: next-method-quot* ( class generic combination -- quot )
GENERIC: next-method-quot* ( class generic combination -- quot ) ;
: next-method-quot ( method -- quot )
next-method-quot-cache get [
@ -103,7 +103,7 @@ ERROR: check-method-error class generic ;
outdated-generics get members [ generic? ] filter
[ make-generic ] each ;
GENERIC: update-generic ( class generic -- )
GENERIC: update-generic ( class generic -- ) ;
: with-methods ( class generic quot -- )
[ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
@ -128,7 +128,7 @@ M: method crossref?
[ method-word-name f <word> ] [ method-word-props ] 2bi
>>props ;
GENERIC: implementor-classes ( obj -- class )
GENERIC: implementor-classes ( obj -- class ) ;
M: maybe implementor-classes class>> 1array ;
@ -186,7 +186,7 @@ M: method forget*
[ call-next-method ] bi
] if ;
GENERIC# check-combination-effect 1 ( combination effect -- )
GENERIC# check-combination-effect 1 ( combination effect -- ) ;
M: object check-combination-effect 2drop ;

4
core/generic/hook/hook-tests.factor
View File

@ -3,7 +3,7 @@ namespaces sequences strings tools.test vectors words ;
in: generic.hook.tests
symbol: my-var
HOOK: my-hook my-var ( -- x )
HOOK: my-hook my-var ( -- x ) ;
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
@ -12,7 +12,7 @@ M: string my-hook "a string" ;
{ "a string" } [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
HOOK: call-next-hooker my-var ( -- x )
HOOK: call-next-hooker my-var ( -- x ) ;
M: sequence call-next-hooker "sequence" ;

4
core/generic/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators effects.parser generic
kernel namespaces parser quotations sequences words ;
kernel namespaces parser quotations sequences words lexer ;
in: generic.parser
ERROR: not-in-a-method-error ;
@ -9,7 +9,7 @@ ERROR: not-in-a-method-error ;
: scan-new-generic ( -- word ) scan-new dup reset-word ;
: (GENERIC:) ( quot -- )
[ scan-new-generic ] dip call scan-effect define-generic ; inline
[ scan-new-generic ] dip call scan-effect ";" expect define-generic ; inline
: create-method-in ( class generic -- method )
create-method dup set-last-word dup save-location ;

2
core/generic/single/single-docs.factor
View File

@ -12,7 +12,7 @@ HELP: inconsistent-next-method
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
"GENERIC: error-test ( object -- ) ;"
""
"M: string error-test print ;"
""

10
core/generic/single/single.factor
View File

@ -25,7 +25,7 @@ PREDICATE: single-generic < generic
M: single-generic make-inline cannot-be-inline ;
GENERIC: dispatch# ( word -- n )
GENERIC: dispatch# ( word -- n ) ;
M: generic dispatch# "combination" word-prop dispatch# ;
@ -37,7 +37,7 @@ symbol: combination
: with-combination ( combination quot -- )
[ combination ] dip with-variable ; inline
HOOK: picker combination ( -- quot )
HOOK: picker combination ( -- quot ) ;
M: single-combination next-method-quot* ( class generic combination -- quot )
[
@ -148,7 +148,7 @@ C: <tag-dispatch-engine> tag-dispatch-engine
<tag-dispatch-engine> ;
! ! ! Compile engine ! ! !
GENERIC: compile-engine ( engine -- obj )
GENERIC: compile-engine ( engine -- obj ) ;
: compile-engines ( assoc -- assoc' )
[ compile-engine ] assoc-map ;
@ -260,7 +260,7 @@ M: f compile-engine ;
[ <engine> compile-engine ] bi
] tri ;
HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f ) ;
M: single-combination inline-cache-quots 2drop f f ;
@ -269,7 +269,7 @@ M: single-combination inline-cache-quots 2drop f f ;
[ >>pic-def ] [ >>pic-tail-def ] bi*
drop ;
HOOK: mega-cache-quot combination ( methods -- quot/f )
HOOK: mega-cache-quot combination ( methods -- quot/f ) ;
M: single-combination perform-combination
[

78
core/generic/standard/standard-tests.factor
View File

@ -8,7 +8,7 @@ QUALIFIED-WITH: alien.c-types c
SPECIALIZED-VECTOR: c:double
in: generic.standard.tests
GENERIC: class-of ( x -- y )
GENERIC: class-of ( x -- y ) ;
M: fixnum class-of drop "fixnum" ;
M: word class-of drop "word" ;
@ -17,14 +17,14 @@ M: word class-of drop "word" ;
{ "word" } [ \ class-of class-of ] unit-test
[ 3.4 class-of ] must-fail
GENERIC: foobar ( x -- y )
GENERIC: foobar ( x -- y ) ;
M: object foobar drop "Hello world" ;
M: fixnum foobar drop "Goodbye cruel world" ;
{ "Hello world" } [ 4 foobar foobar ] unit-test
{ "Goodbye cruel world" } [ 4 foobar ] unit-test
GENERIC: lo-tag-test ( obj -- obj' )
GENERIC: lo-tag-test ( obj -- obj' ) ;
M: integer lo-tag-test 3 + ;
M: float lo-tag-test 4 - ;
@ -36,7 +36,7 @@ M: complex lo-tag-test sq ;
{ -1/2 } [ 1+1/2 lo-tag-test ] unit-test
{ -16 } [ C{ 0 4 } lo-tag-test ] unit-test
GENERIC: hi-tag-test ( obj -- obj' )
GENERIC: hi-tag-test ( obj -- obj' ) ;
M: string hi-tag-test ", in bed" append ;
M: integer hi-tag-test 3 + ;
@ -51,11 +51,11 @@ M: sequence hi-tag-test reverse ;
UNION: funnies quotation float complex ;
GENERIC: funny ( x -- y )
GENERIC: funny ( x -- y ) ;
M: funnies funny drop 2 ;
M: object funny drop 0 ;
GENERIC: union-containment ( x -- y )
GENERIC: union-containment ( x -- y ) ;
M: integer union-containment drop 1 ;
M: number union-containment drop 2 ;
@ -81,7 +81,7 @@ TUPLE: circle < shape radius ;
C: <circle> circle
GENERIC: area ( shape -- n )
GENERIC: area ( shape -- n ) ;
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
@ -91,7 +91,7 @@ M: circle area radius>> sq pi * ;
{ 12 } [ 4 3 2 <parallelogram> area ] unit-test
{ t } [ 2 <circle> area 4 pi * = ] unit-test
GENERIC: perimeter ( shape -- n )
GENERIC: perimeter ( shape -- n ) ;
: rectangle-perimeter ( l w -- n ) + 2 * ;
@ -113,12 +113,12 @@ M: circle perimeter 2 * pi * ;
PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
GENERIC: gooey ( x -- y ) ;
M: very-funny gooey sq ;
{ 0.25 } [ 0.5 gooey ] unit-test
GENERIC: empty-method-test ( x -- y )
GENERIC: empty-method-test ( x -- y ) ;
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
C: <for-arguments-sake> for-arguments-sake
@ -131,7 +131,7 @@ C: <another-one> another-one
{ "Hi" } [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
{ T{ another-one f } } [ <another-one> empty-method-test ] unit-test
GENERIC: big-mix-test ( obj -- obj' )
GENERIC: big-mix-test ( obj -- obj' ) ;
M: object big-mix-test drop "object" ;
@ -171,7 +171,7 @@ M: circle big-mix-test drop "circle" ;
{ "tuple" } [ H{ } big-mix-test ] unit-test
{ "object" } [ \ + big-mix-test ] unit-test
GENERIC: small-lo-tag ( obj -- obj )
GENERIC: small-lo-tag ( obj -- obj ) ;
M: fixnum small-lo-tag drop "fixnum" ;
@ -188,13 +188,13 @@ M: byte-array small-lo-tag drop "byte-array" ;
{ "double-array" } [ double-array{ 1.0 } small-lo-tag ] unit-test
! Testing recovery from bad method definitions
"IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- )
"IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ;
[
"IN: generic.standard.tests M: dictionary unhappy ;" eval( -- )
] must-fail
{ } [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
{ } [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ; ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
GENERIC# complex-combination 1 ( a b -- c ) ;
M: string complex-combination drop ;
M: object complex-combination nip ;
@ -206,7 +206,7 @@ TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
GENERIC: wii ( x -- y )
GENERIC: wii ( x -- y ) ;
M: both wii drop 3 ;
M: second-one wii drop 4 ;
M: tuple-class wii drop 5 ;
@ -214,7 +214,7 @@ M: integer wii drop 6 ;
{ 3 } [ T{ first-one } wii ] unit-test
GENERIC: tag-and-f ( x -- x x )
GENERIC: tag-and-f ( x -- x x ) ;
M: fixnum tag-and-f 1 ;
@ -229,7 +229,7 @@ M: f tag-and-f 4 ;
{ 3.4 3 } [ 3.4 tag-and-f ] unit-test
! Issues with forget
GENERIC: generic-forget-test ( a -- b )
GENERIC: generic-forget-test ( a -- b ) ;
M: f generic-forget-test ;
@ -247,10 +247,10 @@ M: f generic-forget-test ;
{ } [
"IN: generic.standard.tests
GENERIC: jeah ( a -- b )
GENERIC: jeah ( a -- b ) ;
TUPLE: boii ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
GENERIC: jeah* ( a -- b ) ;
M: boii jeah* jeah ;" eval( -- )
"IN: generic.standard.tests
@ -282,7 +282,7 @@ TUPLE: executive < senior-manager ;
TUPLE: ceo < executive ;
GENERIC: salary ( person -- n )
GENERIC: salary ( person -- n ) ;
M: intern salary
! Intentional mistake.
@ -332,7 +332,7 @@ UNION: y a c ;
UNION: z x y ;
GENERIC: funky* ( obj -- )
GENERIC: funky* ( obj -- ) ;
M: z funky* "z" , drop ;
@ -358,14 +358,14 @@ M: c funky* "c" , call-next-method ;
] unit-test
! Changing method combination should not fail
{ } [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
{ } [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ; ] unit-test
{ } [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
{ f } [ "xyz" "generic.standard.tests" lookup-word pic-def>> ] unit-test
{ f } [ "xyz" "generic.standard.tests" lookup-word "decision-tree" word-prop ] unit-test
! Corner cases
[ "IN: generic.standard.tests GENERIC: broken-generic ( -- )" eval( -- ) ]
[ "IN: generic.standard.tests GENERIC: broken-generic ( -- )" eval( -- ) ; ]
[ error>> bad-dispatch-position? ]
must-fail-with
[ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
@ -379,11 +379,11 @@ must-fail-with
must-fail-with
! Generic words cannot be inlined
{ } [ "IN: generic.standard.tests GENERIC: foo ( x -- x )" eval( -- ) ] unit-test
[ "IN: generic.standard.tests GENERIC: foo ( x -- x ) inline" eval( -- ) ] must-fail
{ } [ "IN: generic.standard.tests GENERIC: foo ( x -- x )" eval( -- ) ; ] unit-test
[ "IN: generic.standard.tests GENERIC: foo ( x -- x ) inline" eval( -- ) ; ] must-fail
! Moving a method from one vocab to another didn't always work
GENERIC: move-method-generic ( a -- b )
GENERIC: move-method-generic ( a -- b ) ;
{ } [ "IN: generic.standard.tests.a USE: strings USE: generic.standard.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
@ -394,7 +394,7 @@ GENERIC: move-method-generic ( a -- b )
{ { string } } [ \ move-method-generic order ] unit-test
! FORGET: on method wrappers
GENERIC: forget-test ( a -- b )
GENERIC: forget-test ( a -- b ) ;
M: integer forget-test 3 + ;
@ -408,20 +408,20 @@ M: integer forget-test 3 + ;
[ 10 forget-test ] [ no-method? ] must-fail-with
! Declarations on methods
GENERIC: flushable-generic ( a -- b ) flushable
GENERIC: flushable-generic ( a -- b ) ; flushable
M: integer flushable-generic ;
{ t } [ \ flushable-generic flushable? ] unit-test
{ t } [ M\ integer flushable-generic flushable? ] unit-test
GENERIC: non-flushable-generic ( a -- b )
GENERIC: non-flushable-generic ( a -- b ) ;
M: integer non-flushable-generic ; flushable
{ f } [ \ non-flushable-generic flushable? ] unit-test
{ t } [ M\ integer non-flushable-generic flushable? ] unit-test
! method-for-object, method-for-class, effective-method
GENERIC: foozul ( a -- b )
GENERIC: foozul ( a -- b ) ;
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
@ -438,7 +438,7 @@ M: slice foozul ;
UNION: amb-union-1a integer float ;
UNION: amb-union-1b float string ;
GENERIC: amb-generic-1 ( a -- b )
GENERIC: amb-generic-1 ( a -- b ) ;
M: amb-union-1a amb-generic-1 drop "a" ;
M: amb-union-1b amb-generic-1 drop "b" ;
@ -456,7 +456,7 @@ M: amb-union-1b amb-generic-1 drop "b" ;
UNION: amb-union-2a float string ;
UNION: amb-union-2b integer float ;
GENERIC: amb-generic-2 ( a -- b )
GENERIC: amb-generic-2 ( a -- b ) ;
M: amb-union-2a amb-generic-2 drop "a" ;
M: amb-union-2b amb-generic-2 drop "b" ;
@ -475,7 +475,7 @@ TUPLE: amb-tuple-a x ;
TUPLE: amb-tuple-b < amb-tuple-a ;
PREDICATE: amb-tuple-c < amb-tuple-a x>> 3 = ;
GENERIC: amb-generic-3 ( a -- b )
GENERIC: amb-generic-3 ( a -- b ) ;
M: amb-tuple-b amb-generic-3 drop "b" ;
M: amb-tuple-c amb-generic-3 drop "c" ;
@ -488,7 +488,7 @@ M: amb-tuple-c amb-generic-3 drop "c" ;
TUPLE: amb-tuple-d ;
UNION: amb-union-4 amb-tuple-a amb-tuple-d ;
GENERIC: amb-generic-4 ( a -- b )
GENERIC: amb-generic-4 ( a -- b ) ;
M: amb-tuple-b amb-generic-4 drop "b" ;
M: amb-union-4 amb-generic-4 drop "4" ;
@ -507,7 +507,7 @@ mixin: amb-mixin-5
INSTANCE: amb-tuple-a amb-mixin-5
INSTANCE: amb-tuple-d amb-mixin-5
GENERIC: amb-generic-5 ( a -- b )
GENERIC: amb-generic-5 ( a -- b ) ;
M: amb-tuple-b amb-generic-5 drop "b" ;
M: amb-mixin-5 amb-generic-5 drop "5" ;
@ -524,7 +524,7 @@ M: amb-mixin-5 amb-generic-5 drop "5" ;
UNION: amb-union-6 amb-tuple-b amb-tuple-d ;
GENERIC: amb-generic-6 ( a -- b )
GENERIC: amb-generic-6 ( a -- b ) ;
M: amb-tuple-a amb-generic-6 drop "a" ;
M: amb-union-6 amb-generic-6 drop "6" ;
@ -543,7 +543,7 @@ mixin: amb-mixin-7
INSTANCE: amb-tuple-b amb-mixin-7
INSTANCE: amb-tuple-d amb-mixin-7
GENERIC: amb-generic-7 ( a -- b )
GENERIC: amb-generic-7 ( a -- b ) ;
M: amb-tuple-a amb-generic-7 drop "a" ;
M: amb-mixin-7 amb-generic-7 drop "7" ;
@ -564,7 +564,7 @@ PREDICATE: amb-predicate-b < amb-predicate-a 10 mod 4 = ;
UNION: amb-union-8 amb-predicate-b string ;
GENERIC: amb-generic-8 ( a -- b )
GENERIC: amb-generic-8 ( a -- b ) ;
M: amb-union-8 amb-generic-8 drop "8" ;
M: amb-predicate-a amb-generic-8 drop "a" ;

2
core/grouping/grouping.factor
View File

@ -8,7 +8,7 @@ ERROR: groups-error seq n ;
<PRIVATE
GENERIC: group@ ( n groups -- from to seq )
GENERIC: group@ ( n groups -- from to seq ) ;
TUPLE: chunking { seq read-only } { n read-only } ;

2
core/growable/growable.factor
View File

@ -30,7 +30,7 @@ PRIVATE>
: expand ( len seq -- )
[ resize ] change-underlying drop ; inline
GENERIC: contract ( len seq -- )
GENERIC: contract ( len seq -- ) ;
M: growable contract ( len seq -- )
[ length ] keep

2
core/hashtables/wrapped/wrapped.factor
View File

@ -11,7 +11,7 @@ TUPLE: wrapped-key
TUPLE: wrapped-hashtable
{ underlying hashtable read-only } ;
GENERIC: wrap-key ( key wrapped-hash -- wrapped-key )
GENERIC: wrap-key ( key wrapped-hash -- wrapped-key ) ;
<PRIVATE

2
core/hints/hints-docs.factor
View File

@ -33,7 +33,7 @@ $nl
"Specializers can also be defined on methods:"
{ $code
"USING: assocs hashtables hints kernel sequences ;"
"GENERIC: count-occurrences ( elt obj -- n )"
"GENERIC: count-occurrences ( elt obj -- n ) ;"
""
"M: sequence count-occurrences [ = ] with count ;"
""

2
core/hints/hints-tests.factor
View File

@ -3,7 +3,7 @@ compiler.tree.debugger tools.test ;
in: hints.tests
! Regression
GENERIC: blahblah ( a b c -- )
GENERIC: blahblah ( a b c -- ) ;
M: hashtable blahblah 2nip [ 1 + ] change-count drop ;

4
core/hints/hints.factor
View File

@ -8,13 +8,13 @@ namespaces parser sbufs sequences sequences.private splitting
splitting.private strings vectors words ;
in: hints
GENERIC: specializer-predicate ( spec -- quot )
GENERIC: specializer-predicate ( spec -- quot ) ;
M: class specializer-predicate predicate-def ;
M: object specializer-predicate '[ _ eq? ] ;
GENERIC: specializer-declaration ( spec -- class )
GENERIC: specializer-declaration ( spec -- class ) ;
M: class specializer-declaration ;

10
core/io/backend/backend.factor
View File

@ -10,20 +10,20 @@ singleton: c-io-backend
io-backend [ c-io-backend ] initialize
HOOK: init-io io-backend ( -- )
HOOK: init-io io-backend ( -- ) ;
HOOK: init-stdio io-backend ( -- )
HOOK: init-stdio io-backend ( -- ) ;
: set-stdio ( input output error -- )
[ utf8 <decoder> input-stream set-global ]
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( nanos -- )
HOOK: io-multiplex io-backend ( nanos -- ) ;
HOOK: normalize-directory io-backend ( path -- path' )
HOOK: normalize-directory io-backend ( path -- path' ) ;
HOOK: normalize-path io-backend ( path -- path' )
HOOK: normalize-path io-backend ( path -- path' ) ;
M: object normalize-directory normalize-path ;

2
core/io/encodings/ascii/ascii.factor
View File

@ -12,7 +12,7 @@ M: ascii encode-char
<PRIVATE
GENERIC: ascii> ( string -- byte-array )
GENERIC: ascii> ( string -- byte-array ) ;
M: object ascii>
[ dup 127 <= [ encode-error ] unless ] B{ } map-as ; inline

20
core/io/encodings/encodings.factor
View File

@ -7,15 +7,15 @@ in: io.encodings
! The encoding descriptor protocol
GENERIC: guess-encoded-length ( string-length encoding -- byte-length )
GENERIC: guess-decoded-length ( byte-length encoding -- string-length )
GENERIC: guess-encoded-length ( string-length encoding -- byte-length ) ;
GENERIC: guess-decoded-length ( byte-length encoding -- string-length ) ;
M: object guess-decoded-length drop ; inline
M: object guess-encoded-length drop ; inline
GENERIC: decode-char ( stream encoding -- char/f )
GENERIC: decode-char ( stream encoding -- char/f ) ;
GENERIC: decode-until ( seps stream encoding -- string/f sep/f )
GENERIC: decode-until ( seps stream encoding -- string/f sep/f ) ;
<PRIVATE
@ -65,20 +65,20 @@ CONSTANT: replacement-char 0xfffd
PRIVATE>
GENERIC: encode-char ( char stream encoding -- )
GENERIC: encode-char ( char stream encoding -- ) ;
GENERIC: encode-string ( string stream encoding -- )
GENERIC: encode-string ( string stream encoding -- ) ;
M: object encode-string [ encode-char ] 2curry each ; inline
GENERIC: <decoder> ( stream encoding -- newstream )
GENERIC: <decoder> ( stream encoding -- newstream ) ;
TUPLE: decoder { stream read-only } { code read-only } { cr boolean } ;
INSTANCE: decoder input-stream
ERROR: decode-error ;
GENERIC: <encoder> ( stream encoding -- newstream )
GENERIC: <encoder> ( stream encoding -- newstream ) ;
TUPLE: encoder { stream read-only } { code read-only } ;
INSTANCE: encoder output-stream
@ -205,7 +205,7 @@ INSTANCE: encoder plain-writer
PRIVATE>
GENERIC# re-encode 1 ( stream encoding -- newstream )
GENERIC# re-encode 1 ( stream encoding -- newstream ) ;
M: object re-encode <encoder> ;
@ -218,7 +218,7 @@ M: encoder re-encode [ stream>> ] dip re-encode ;
[ [ output-stream get ] dip re-encode ] dip
with-output-stream* ; inline
GENERIC# re-decode 1 ( stream encoding -- newstream )
GENERIC# re-decode 1 ( stream encoding -- newstream ) ;
M: object re-decode <decoder> ;

4
core/io/encodings/utf16/utf16.factor
View File

@ -114,7 +114,7 @@ M: utf16le encode-char ( char stream encoding -- )
: ascii-string>utf16be ( string stream -- )
[ 1 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
GENERIC# encode-string-utf16le 1 ( string stream -- )
GENERIC# encode-string-utf16le 1 ( string stream -- ) ;
M: object encode-string-utf16le
[ char>utf16le ] curry each ; inline
@ -126,7 +126,7 @@ M: string encode-string-utf16le
M: utf16le encode-string drop encode-string-utf16le ;
GENERIC# encode-string-utf16be 1 ( string stream -- )
GENERIC# encode-string-utf16be 1 ( string stream -- ) ;
M: object encode-string-utf16be
[ char>utf16be ] curry each ; inline

2
core/io/encodings/utf8/utf8.factor
View File

@ -84,7 +84,7 @@ M: utf8 decode-until (decode-until) ;
M: utf8 encode-char
drop char>utf8 ;
GENERIC# encode-string-utf8 1 ( string stream -- )
GENERIC# encode-string-utf8 1 ( string stream -- ) ;
M: object encode-string-utf8
[ char>utf8 ] curry each ; inline

16
core/io/files/files.factor
View File

@ -15,10 +15,10 @@ symbol: +output+
! Returns an event to wait for which will ensure completion of
! this request
GENERIC: drain ( port handle -- event/f )
GENERIC: refill ( port handle -- event/f )
GENERIC: drain ( port handle -- event/f ) ;
GENERIC: refill ( port handle -- event/f ) ;
HOOK: wait-for-fd io-backend ( handle event -- )
HOOK: wait-for-fd io-backend ( handle event -- ) ;
mixin: file-reader
mixin: file-writer
@ -26,11 +26,11 @@ mixin: file-writer
M: file-reader stream-element-type drop +byte+ ; inline
M: file-writer stream-element-type drop +byte+ ; inline
HOOK: (file-reader) io-backend ( path -- stream )
HOOK: (file-reader) io-backend ( path -- stream ) ;
HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-writer) io-backend ( path -- stream ) ;
HOOK: (file-appender) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream ) ;
: <file-reader> ( path encoding -- stream )
[ normalize-path (file-reader) { file-reader } declare ] dip <decoder> ; inline
@ -76,9 +76,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
! Current directory
<PRIVATE
HOOK: cd io-backend ( path -- )
HOOK: cd io-backend ( path -- ) ;
HOOK: cwd io-backend ( -- path )
HOOK: cwd io-backend ( -- path ) ;
M: object cwd ( -- path ) "." ;

30
core/io/io.factor
View File

@ -6,29 +6,29 @@ in: io
SYMBOLS: +byte+ +character+ ;
GENERIC: stream-element-type ( stream -- type )
GENERIC: stream-element-type ( stream -- type ) ;
GENERIC: stream-read1 ( stream -- elt )
GENERIC: stream-read-unsafe ( n buf stream -- count )
GENERIC: stream-read-until ( seps stream -- seq sep/f )
GENERIC: stream-read-partial-unsafe ( n buf stream -- count )
GENERIC: stream-readln ( stream -- str/f )
GENERIC: stream-contents* ( stream -- seq )
GENERIC: stream-read1 ( stream -- elt ) ;
GENERIC: stream-read-unsafe ( n buf stream -- count ) ;
GENERIC: stream-read-until ( seps stream -- seq sep/f ) ;
GENERIC: stream-read-partial-unsafe ( n buf stream -- count ) ;
GENERIC: stream-readln ( stream -- str/f ) ;
GENERIC: stream-contents* ( stream -- seq ) ;
: stream-contents ( stream -- seq ) [ stream-contents* ] with-disposal ;
GENERIC: stream-write1 ( elt stream -- )
GENERIC: stream-write ( data stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
GENERIC: stream-write1 ( elt stream -- ) ;
GENERIC: stream-write ( data stream -- ) ;
GENERIC: stream-flush ( stream -- ) ;
GENERIC: stream-nl ( stream -- ) ;
ERROR: bad-seek-type type ;
SINGLETONS: seek-absolute seek-relative seek-end ;
GENERIC: stream-tell ( stream -- n )
GENERIC: stream-seek ( n seek-type stream -- )
GENERIC: stream-seekable? ( stream -- ? )
GENERIC: stream-length ( stream -- n/f )
GENERIC: stream-tell ( stream -- n ) ;
GENERIC: stream-seek ( n seek-type stream -- ) ;
GENERIC: stream-seekable? ( stream -- ? ) ;
GENERIC: stream-length ( stream -- n/f ) ;
: stream-print ( str stream -- )
[ stream-write ] [ stream-nl ] bi ; inline

10
core/io/pathnames/pathnames.factor
View File

@ -19,7 +19,7 @@ symbol: current-directory
: last-path-separator ( path -- n ? )
[ length 1 - ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? )
HOOK: root-directory? io-backend ( path -- ? ) ;
M: object root-directory? ( path -- ? )
[ f ] [ [ path-separator? ] all? ] if-empty ;
@ -128,20 +128,20 @@ PRIVATE>
: path-components ( path -- seq )
normalize-path path-separator split harvest ;
HOOK: resolve-symlinks os ( path -- path' )
HOOK: resolve-symlinks os ( path -- path' ) ;
M: object resolve-symlinks normalize-path ;
: resource-path ( path -- newpath )
"resource-path" get prepend-path ;
HOOK: home io-backend ( -- dir )
HOOK: home io-backend ( -- dir ) ;
M: object home "" resource-path ;
GENERIC: vocab-path ( path -- newpath )
GENERIC: vocab-path ( path -- newpath ) ;
GENERIC: absolute-path ( path -- path' )
GENERIC: absolute-path ( path -- path' ) ;
M: string absolute-path
"resource:" ?head [

2
core/kernel/kernel-docs.factor
View File

@ -744,7 +744,7 @@ HELP: set-special-object
HELP: object
{ $class-description
"The class of all objects. If a generic word defines a method specializing on this class, the method is used as a fallback, if no other applicable method is found. For instance:"
{ $code "GENERIC: enclose ( number -- array )" "M: number enclose 1array ;" "M: object enclose ;" }
{ $code "GENERIC: enclose ( number -- array ) ;" "M: number enclose 1array ;" "M: object enclose ;" }
} ;
HELP: null

16
core/kernel/kernel.factor
View File

@ -71,9 +71,9 @@ DEFER: 3dip
: clear ( -- ) { } set-datastack ;
! Combinators
GENERIC: call ( callable -- )
GENERIC: call ( callable -- ) ;
GENERIC: execute ( word -- )
GENERIC: execute ( word -- ) ;
DEFER: if
@ -247,7 +247,7 @@ UNION: boolean postpone: t postpone: f ;
[ [ not ] compose ] dip while ; inline
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
GENERIC: hashcode* ( depth obj -- code ) ;
M: object hashcode* 2drop 0 ; inline
@ -265,7 +265,7 @@ M: f hashcode* 2drop 31337 ; inline
] if
] unless ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
GENERIC: equal? ( obj1 obj2 -- ? ) ;
M: object equal? 2drop f ; inline
@ -282,20 +282,20 @@ M: identity-tuple hashcode* nip identity-hashcode ; inline
: same? ( x y quot -- ? ) bi@ = ; inline
GENERIC: clone ( obj -- cloned )
GENERIC: clone ( obj -- cloned ) ;
M: object clone ; inline
M: callstack clone (clone) ; inline
! Tuple construction
GENERIC: new ( class -- tuple )
GENERIC: new ( class -- tuple ) ;
GENERIC: boa ( slots... class -- tuple )
GENERIC: boa ( slots... class -- tuple ) ;
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
GENERIC: throw ( error -- * )
GENERIC: throw ( error -- * ) ;
ERROR: assert got expect ;

4
core/lexer/lexer.factor
View File

@ -61,7 +61,7 @@ ERROR: unexpected want got ;
[ check-lexer [ column>> ] [ line-text>> ] bi ] prepose
keep column<< ; inline
GENERIC: skip-blank ( lexer -- )
GENERIC: skip-blank ( lexer -- ) ;
<PRIVATE
@ -81,7 +81,7 @@ M: lexer skip-blank
[ t skip ] change-lexer-column
] if ;
GENERIC: skip-word ( lexer -- )
GENERIC: skip-word ( lexer -- ) ;
M: lexer skip-word
[

2
core/locals/definitions/definitions.factor
View File

@ -9,7 +9,7 @@ PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
! Lambdas/locals need to expose their uninterned subwords in order
! to make a boot image.
GENERIC: lambda-subwords ( obj -- )
GENERIC: lambda-subwords ( obj -- ) ;
M: object lambda-subwords drop ;

18
core/locals/locals-tests.factor
View File

@ -101,9 +101,9 @@ write-test-2 "q" set
{ 13 } [ 10 let-let-test ] unit-test
GENERIC: lambda-generic ( a b -- c )
GENERIC: lambda-generic ( a b -- c ) ;
GENERIC# lambda-generic-1 1 ( a b -- c )
GENERIC# lambda-generic-1 1 ( a b -- c ) ;
M:: integer lambda-generic-1 ( a b -- c ) a b * ;
@ -112,7 +112,7 @@ M:: string lambda-generic-1 ( a b -- c )
M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
GENERIC# lambda-generic-2 1 ( a b -- c )
GENERIC# lambda-generic-2 1 ( a b -- c ) ;
M:: integer lambda-generic-2 ( a b -- c )
a CHAR: x <string> b lambda-generic ;
@ -150,20 +150,20 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
DEFER: xyzzy
{ } [
"IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
"IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) ; M: integer xyzzy ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
{ 10 } [ 10 xyzzy ] unit-test
{ } [
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) ; 5 ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
{ 5 } [ 10 xyzzy ] unit-test
GENERIC: next-method-test ( a -- b )
GENERIC: next-method-test ( a -- b ) ;
M: integer next-method-test 3 + ;
@ -196,7 +196,7 @@ CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals
CONSTANT: method-definition "USING: locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
GENERIC: method-with-locals ( x -- y )
GENERIC: method-with-locals ( x -- y ) ;
M:: sequence method-with-locals ( a -- y ) a reverse ;
@ -379,7 +379,7 @@ ERROR: punned-class x ;
\ littledan-case-problem-4 def>> must-infer
*/
GENERIC: lambda-method-forget-test ( a -- b )
GENERIC: lambda-method-forget-test ( a -- b ) ;
M:: integer lambda-method-forget-test ( a -- b ) a ;
@ -482,7 +482,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
{ 3 } [ 3 t erg's-:>-bug-2 ] unit-test
! dharmatech found this problem
GENERIC: ed's-bug ( a -- b )
GENERIC: ed's-bug ( a -- b ) ;
M: string ed's-bug reverse ;
M: integer ed's-bug neg ;

6
core/locals/rewrite/closures/closures.factor
View File

@ -8,7 +8,7 @@ in: locals.rewrite.closures
! Step 2: identify free variables and make them into explicit
! parameters of lambdas which are curried on
GENERIC: rewrite-closures* ( obj -- )
GENERIC: rewrite-closures* ( obj -- ) ;
: (rewrite-closures) ( form -- form' )
[ [ rewrite-closures* ] each ] [ ] make ;
@ -16,7 +16,7 @@ GENERIC: rewrite-closures* ( obj -- )
: rewrite-closures ( form -- form' )
expand-macros (rewrite-sugar) (rewrite-closures) point-free ;
GENERIC: defs-vars* ( seq form -- seq' )
GENERIC: defs-vars* ( seq form -- seq' ) ;
: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce members ;
@ -26,7 +26,7 @@ M: quotation defs-vars* [ defs-vars* ] each ;
M: object defs-vars* drop ;
GENERIC: uses-vars* ( seq form -- seq' )
GENERIC: uses-vars* ( seq form -- seq' ) ;
: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce members ;

2
core/locals/rewrite/point-free/point-free.factor
View File

@ -15,7 +15,7 @@ in: locals.rewrite.point-free
: read-local-quot ( args obj -- quot )
local-index neg [ get-local ] curry ;
GENERIC: localize ( args obj -- args quot )
GENERIC: localize ( args obj -- args quot ) ;
M: local localize dupd read-local-quot ;

8
core/locals/rewrite/sugar/sugar.factor
View File

@ -10,12 +10,12 @@ in: locals.rewrite.sugar
! literals with locals in them into code which constructs
! the literal after pushing locals on the stack
GENERIC: rewrite-sugar* ( obj -- )
GENERIC: rewrite-sugar* ( obj -- ) ;
: (rewrite-sugar) ( form -- form' )
[ rewrite-sugar* ] [ ] make ;
GENERIC: quotation-rewrite ( form -- form' )
GENERIC: quotation-rewrite ( form -- form' ) ;
M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
@ -29,7 +29,7 @@ M: callable rewrite-sugar* quotation-rewrite , ;
M: lambda rewrite-sugar* quotation-rewrite , ;
GENERIC: rewrite-literal? ( obj -- ? )
GENERIC: rewrite-literal? ( obj -- ? ) ;
M: special rewrite-literal? drop t ;
@ -47,7 +47,7 @@ M: tuple rewrite-literal? tuple>array rewrite-literal? ;
M: object rewrite-literal? drop f ;
GENERIC: rewrite-element ( obj -- )
GENERIC: rewrite-element ( obj -- ) ;
: rewrite-elements ( seq -- )
[ rewrite-element ] each ;

8
core/macros/expander/expander.factor
View File

@ -6,7 +6,7 @@ namespaces quotations sequences sequences.private vectors words
;
in: macros.expander
GENERIC: expand-macros ( quot -- quot' )
GENERIC: expand-macros ( quot -- quot' ) ;
symbol: stack
@ -16,13 +16,13 @@ symbol: stack
: end ( -- )
stack get [ [ literalize , ] each ] [ delete-all ] bi ;
GENERIC: condomize? ( obj -- ? )
GENERIC: condomize? ( obj -- ? ) ;
M: array condomize? [ condomize? ] any? ;
M: callable condomize? [ condomize? ] any? ;
M: object condomize? drop f ;
GENERIC: condomize ( obj -- obj' )
GENERIC: condomize ( obj -- obj' ) ;
M: array condomize [ condomize ] map ;
M: callable condomize [ condomize ] map ;
@ -31,7 +31,7 @@ M: object condomize ;
: literal ( obj -- )
dup condomize? [ condomize ] when stack get push ;
GENERIC: expand-macros* ( obj -- )
GENERIC: expand-macros* ( obj -- ) ;
M: wrapper expand-macros* wrapped>> literal ;

100
core/math/math.factor
View File

@ -75,59 +75,59 @@ PRIMITIVE: float>bignum ( x -- y ) ;
PRIMITIVE: float>fixnum ( x -- y ) ;
PRIVATE>
GENERIC: >fixnum ( x -- n ) foldable
GENERIC: >bignum ( x -- n ) foldable
GENERIC: >integer ( x -- n ) foldable
GENERIC: >float ( x -- y ) foldable
GENERIC: integer>fixnum ( x -- y ) foldable
GENERIC: integer>fixnum-strict ( x -- y ) foldable
GENERIC: >fixnum ( x -- n ) ; foldable
GENERIC: >bignum ( x -- n ) ; foldable
GENERIC: >integer ( x -- n ) ; foldable
GENERIC: >float ( x -- y ) ; foldable
GENERIC: integer>fixnum ( x -- y ) ; foldable
GENERIC: integer>fixnum-strict ( x -- y ) ; foldable
GENERIC: numerator ( a/b -- a )
GENERIC: denominator ( a/b -- b )
GENERIC: >fraction ( a/b -- a b )
GENERIC: numerator ( a/b -- a ) ;
GENERIC: denominator ( a/b -- b ) ;
GENERIC: >fraction ( a/b -- a b ) ;
GENERIC: real-part ( z -- x )
GENERIC: imaginary-part ( z -- y )
GENERIC: real-part ( z -- x ) ;
GENERIC: imaginary-part ( z -- y ) ;
MATH: number= ( x y -- ? ) foldable
MATH: number= ( x y -- ? ) ; foldable
M: object number= 2drop f ;
MATH: < ( x y -- ? ) foldable
MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
MATH: < ( x y -- ? ) ; foldable
MATH: <= ( x y -- ? ) ; foldable
MATH: > ( x y -- ? ) ; foldable
MATH: >= ( x y -- ? ) ; foldable
MATH: unordered? ( x y -- ? ) foldable
MATH: u< ( x y -- ? ) foldable
MATH: u<= ( x y -- ? ) foldable
MATH: u> ( x y -- ? ) foldable
MATH: u>= ( x y -- ? ) foldable
MATH: unordered? ( x y -- ? ) ; foldable
MATH: u< ( x y -- ? ) ; foldable
MATH: u<= ( x y -- ? ) ; foldable
MATH: u> ( x y -- ? ) ; foldable
MATH: u>= ( x y -- ? ) ; foldable
M: object unordered? 2drop f ;
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
MATH: / ( x y -- z ) foldable
MATH: /f ( x y -- z ) foldable
MATH: /i ( x y -- z ) foldable
MATH: mod ( x y -- z ) foldable
MATH: + ( x y -- z ) ; foldable
MATH: - ( x y -- z ) ; foldable
MATH: * ( x y -- z ) ; foldable
MATH: / ( x y -- z ) ; foldable
MATH: /f ( x y -- z ) ; foldable
MATH: /i ( x y -- z ) ; foldable
MATH: mod ( x y -- z ) ; foldable
MATH: /mod ( x y -- z w ) foldable
MATH: /mod ( x y -- z w ) ; foldable
MATH: bitand ( x y -- z ) foldable
MATH: bitor ( x y -- z ) foldable
MATH: bitxor ( x y -- z ) foldable
GENERIC# shift 1 ( x n -- y ) foldable
GENERIC: bitnot ( x -- y ) foldable
GENERIC# bit? 1 ( x n -- ? ) foldable
MATH: bitand ( x y -- z ) ; foldable
MATH: bitor ( x y -- z ) ; foldable
MATH: bitxor ( x y -- z ) ; foldable
GENERIC# shift 1 ( x n -- y ) ; foldable
GENERIC: bitnot ( x -- y ) ; foldable
GENERIC# bit? 1 ( x n -- ? ) ; foldable
GENERIC: abs ( x -- y ) foldable
GENERIC: abs ( x -- y ) ; foldable
<PRIVATE
GENERIC: (log2) ( x -- n ) foldable
GENERIC: (log2) ( x -- n ) ; foldable
PRIVATE>
@ -147,7 +147,7 @@ ERROR: log2-expects-positive x ;
: even? ( n -- ? ) 1 bitand zero? ; inline
: odd? ( n -- ? ) 1 bitand 1 number= ; inline
GENERIC: neg? ( x -- -x )
GENERIC: neg? ( x -- -x ) ;
: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
@ -174,7 +174,7 @@ TUPLE: complex
UNION: number real complex ;
GENERIC: recip ( x -- y )
GENERIC: recip ( x -- y ) ;
M: number recip 1 swap / ; inline
@ -182,7 +182,7 @@ M: number recip 1 swap / ; inline
! Note: an imaginary 0.0 should still create a complex
dup 0 = [ drop ] [ complex boa ] if ; inline
GENERIC: >rect ( z -- x y )
GENERIC: >rect ( z -- x y ) ;
M: real >rect 0 ; inline
@ -202,7 +202,7 @@ PRIVATE>
: gcd ( x y -- a d )
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; inline
MATH: simple-gcd ( x y -- d ) foldable
MATH: simple-gcd ( x y -- d ) ; foldable
<PRIVATE
@ -216,13 +216,13 @@ M: bignum simple-gcd bignum-gcd ; inline
: fp-bitwise= ( x y -- ? ) [ double>bits ] same? ; inline
GENERIC: fp-special? ( x -- ? )
GENERIC: fp-nan? ( x -- ? )
GENERIC: fp-qnan? ( x -- ? )
GENERIC: fp-snan? ( x -- ? )
GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits )
GENERIC: fp-sign ( x -- ? )
GENERIC: fp-special? ( x -- ? ) ;
GENERIC: fp-nan? ( x -- ? ) ;
GENERIC: fp-qnan? ( x -- ? ) ;
GENERIC: fp-snan? ( x -- ? ) ;
GENERIC: fp-infinity? ( x -- ? ) ;
GENERIC: fp-nan-payload ( x -- bits ) ;
GENERIC: fp-sign ( x -- ? ) ;
M: object fp-special? drop f ; inline
M: object fp-nan? drop f ; inline
@ -233,8 +233,8 @@ M: object fp-infinity? drop f ; inline
: <fp-nan> ( payload -- nan )
0x7ff0000000000000 bitor bits>double ; inline
GENERIC: next-float ( m -- n )
GENERIC: prev-float ( m -- n )
GENERIC: next-float ( m -- n ) ;
GENERIC: prev-float ( m -- n ) ;
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline

16
core/math/order/order.factor
View File

@ -11,7 +11,7 @@ symbol: +gt+
! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
GENERIC: <=> ( obj1 obj2 -- <=> )
GENERIC: <=> ( obj1 obj2 -- <=> ) ;
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
@ -22,7 +22,7 @@ GENERIC: <=> ( obj1 obj2 -- <=> )
: (real<=>) ( x y -- <=> )
2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
MATH: real<=> ( x y -- <=> )
MATH: real<=> ( x y -- <=> ) ;
M: fixnum real<=> { fixnum fixnum } declare (real<=>) ; inline
M: bignum real<=> { bignum bignum } declare (real<=>) ; inline
M: float real<=> { float float } declare (real<=>) ; inline
@ -32,10 +32,10 @@ PRIVATE>
M: real <=> real<=> ; inline
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )
GENERIC: before=? ( obj1 obj2 -- ? )
GENERIC: after=? ( obj1 obj2 -- ? )
GENERIC: before? ( obj1 obj2 -- ? ) ;
GENERIC: after? ( obj1 obj2 -- ? ) ;
GENERIC: before=? ( obj1 obj2 -- ? ) ;
GENERIC: after=? ( obj1 obj2 -- ? ) ;
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
@ -47,8 +47,8 @@ M: real after? ( obj1 obj2 -- ? ) > ; inline
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
GENERIC: min ( obj1 obj2 -- obj )
GENERIC: max ( obj1 obj2 -- obj )
GENERIC: min ( obj1 obj2 -- obj ) ;
GENERIC: max ( obj1 obj2 -- obj ) ;
M: object min [ before? ] most ; inline
M: object max [ after? ] most ; inline

4
core/math/parser/parser.factor
View File

@ -415,7 +415,7 @@ CONSTANT: ONES B{
[ over 10 >= ] [ (two-digit) ] while
[ over zero? ] [ (one-digit) ] until ; inline
GENERIC: (positive>dec) ( num -- str )
GENERIC: (positive>dec) ( num -- str ) ;
M: bignum (positive>dec)
12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
@ -464,7 +464,7 @@ M: fixnum (positive>dec)
PRIVATE>
GENERIC# >base 1 ( n radix -- str )
GENERIC# >base 1 ( n radix -- str ) ;
: number>string ( n -- str ) 10 >base ; inline

30
core/modern/compiler/compiler.factor
View File

@ -77,7 +77,7 @@ TUPLE: generate-predicate' < define' ;
new
swap >>literal ; inline
GENERIC: split-decorators ( seq -- base left right )
GENERIC: split-decorators ( seq -- base left right ) ;
M: compound-literal split-decorators
sequence>>
[ decorator-literal? not ] partition
@ -85,16 +85,16 @@ M: compound-literal split-decorators
[ left-decorator-literal? ] partition ;
M: object split-decorators f f ;
! GENERIC: apply-decorator ( base decorator -- )
! GENERIC: apply-decorator ( base decorator -- ) ;
! : apply-decorators ( obj seq -- obj ) ;
GENERIC: base-literal ( obj -- obj )
GENERIC: base-literal ( obj -- obj ) ;
M: compound-literal base-literal
sequence>> [ decorator-literal? not ] find nip ;
M: object base-literal ;
GENERIC: literal>tag ( class -- string/f )
GENERIC: literal>tag ( class -- string/f ) ;
M: line-comment-literal literal>tag drop f ;
M: uppercase-colon-literal literal>tag
tag>> [ "word" ] [ >lower ] if-empty ;
@ -112,7 +112,7 @@ M: compound-literal literal>tag
: literals>holders ( literals -- holders )
[ literal>holder ] map ;
GENERIC: holder>definitions' ( literal -- assoc )
GENERIC: holder>definitions' ( literal -- assoc ) ;
M: comment' holder>definitions' drop f ;
M: using' holder>definitions' drop f ;
M: use' holder>definitions' drop f ;
@ -160,7 +160,7 @@ M: slot' holder>definitions'
! these also make class predicate? words
GENERIC: slot-accessor-name ( obj -- string )
GENERIC: slot-accessor-name ( obj -- string ) ;
M: single-matched-literal slot-accessor-name
payload>> first tag>> ">>" append ;
M: tag-literal slot-accessor-name tag>> ">>" append ;
@ -219,12 +219,12 @@ M: singleton' holder>definitions'
[ in'? ] filter
[ literal>> payload>> [ tag>> ] map ] map concat ;
GENERIC: handle-colon-tag ( seq tag -- obj )
GENERIC: handle-paren-tag ( seq tag -- obj )
GENERIC: handle-colon-tag ( seq tag -- obj ) ;
GENERIC: handle-paren-tag ( seq tag -- obj ) ;
! M: f handle-paren-tag drop <effect> ;
GENERIC: handle-brace-tag ( seq tag -- obj )
GENERIC: handle-bracket-tag ( seq tag -- obj )
GENERIC: handle-string-tag ( seq tag -- obj )
GENERIC: handle-brace-tag ( seq tag -- obj ) ;
GENERIC: handle-bracket-tag ( seq tag -- obj ) ;
GENERIC: handle-string-tag ( seq tag -- obj ) ;
ERROR: word-not-found word ;
: lookup-in-namespace ( key namespace -- obj/f )
@ -233,7 +233,7 @@ ERROR: word-not-found word ;
word-not-found
] if ;
GENERIC# lookup-literal 1 ( literal namespace -- obj )
GENERIC# lookup-literal 1 ( literal namespace -- obj ) ;
M: tag-literal lookup-literal
[ tag>> ] dip lookup-in-namespace ;
@ -258,7 +258,7 @@ M: single-matched-literal lookup-literal
} case ;
GENERIC: definition>quotation ( namespace name definition -- quot )
GENERIC: definition>quotation ( namespace name definition -- quot ) ;
M: define' definition>quotation
holder>> definition>quotation
;
@ -268,7 +268,7 @@ M: define' definition>quotation
M: generate-predicate' definition>quotation 3drop f ;
GENERIC: stack-effect? ( obj -- ? )
GENERIC: stack-effect? ( obj -- ? ) ;
M: single-matched-literal stack-effect? { [ tag>> ] [ delimiter>> "(" = ] } 1&& ;
M: object stack-effect? drop f ;
@ -330,7 +330,7 @@ DEFER: load-modern
[ manifest>combined-namespace ] [ definitions>> ] bi
[ [ name>> ] [ ] bi definition>quotation ] with { } map-as concat ;
GENERIC: add-predicates ( obj -- seq )
GENERIC: add-predicates ( obj -- seq ) ;
M: string add-predicates dup "?" append 2array ;
M: sequence add-predicates [ add-predicates ] map concat ;

6
core/modern/modern.factor
View File

@ -52,7 +52,7 @@ TUPLE: compound-sequence-literal sequence ;
CONSTRUCTOR: <compound-sequence-literal> compound-sequence-literal ( sequence -- obj ) ;
>>
GENERIC: lexed-underlying ( obj -- slice )
GENERIC: lexed-underlying ( obj -- slice ) ;
M: f lexed-underlying ;
M: object lexed-underlying underlying>> ;
M: slice lexed-underlying ;
@ -64,7 +64,7 @@ CONSTRUCTOR: <compound-literal> compound-literal ( sequence -- obj ) ;
ERROR: bad-compound-literal seq decorators words ;
: check-compound-literal ( seq -- seq ) ;
GENERIC: make-compound-literals ( seq -- seq' )
GENERIC: make-compound-literals ( seq -- seq' ) ;
M: object make-compound-literals ;
M: array make-compound-literals
[
@ -78,7 +78,7 @@ M: array make-compound-literals
! We have empty decorators, just the @ right here
! wrap the decorated object in the payload slot
GENERIC: collapse-decorators ( seq -- seq' )
GENERIC: collapse-decorators ( seq -- seq' ) ;
M: object collapse-decorators ;
M: array collapse-decorators
[

2
core/modern/out/out.factor
View File

@ -14,7 +14,7 @@ symbol: last-slice
[ last-slice namespaces:set ] bi ;
DEFER: write-literal
GENERIC: write-literal ( obj -- )
GENERIC: write-literal ( obj -- ) ;
! M: object write-literal lexed-underlying write ;
M: string write-literal write ;
M: slice write-literal [ write-whitespace ] [ write ] bi ;

26
core/parser/parser-tests.factor
View File

@ -129,7 +129,7 @@ DEFER: foo
{ f } [ "smudge-me" "parser.tests" lookup-word >boolean ] unit-test
{ 3 } [
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) ; M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" path>source-file definitions>> first cardinality
@ -143,7 +143,7 @@ DEFER: foo
] unit-test
{ 2 } [
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) ; M: integer smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" path>source-file definitions>> first cardinality
@ -234,7 +234,7 @@ DEFER: foo
! Turning a generic into a non-generic could cause all
! kinds of funnyness
{ } [
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) ; M: object ayy ;"
<string-reader> "ayy" parse-stream drop
] unit-test
@ -244,7 +244,7 @@ DEFER: foo
] unit-test
{ } [
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b ) ;"
<string-reader> "azz" parse-stream drop
] unit-test
@ -254,7 +254,7 @@ DEFER: foo
] unit-test
{ } [
"IN: azz GENERIC: a-generic ( a -- b )"
"IN: azz GENERIC: a-generic ( a -- b ) ;"
<string-reader> "azz" parse-stream drop
] unit-test
@ -280,7 +280,7 @@ DEFER: foo
] unit-test
{ } [
"IN: parser.tests GENERIC: killer? ( a -- b )"
"IN: parser.tests GENERIC: killer? ( a -- b ) ;"
<string-reader> "removing-the-predicate" parse-stream drop
] unit-test
@ -289,7 +289,7 @@ DEFER: foo
] unit-test
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b ) ;"
<string-reader> "removing-the-predicate" parse-stream
] [ error>> error>> error>> redefine-error? ] must-fail-with
@ -359,7 +359,7 @@ DEFER: foo
2 [
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b ) ;"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
@ -371,14 +371,14 @@ DEFER: foo
[ f ] [ f "foo" "parser.tests" lookup-word execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b ) ;"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup-word execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b ) ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
@ -428,7 +428,7 @@ DEFER: foo
{
"IN: parser.tests"
"USING: math arrays kernel ;"
"GENERIC: change-combination ( obj a -- b )"
"GENERIC: change-combination ( obj a -- b ) ;"
"M: integer change-combination 2drop 1 ;"
"M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
@ -498,7 +498,7 @@ SYMBOLS: a b c ;
DEFER: blah
{ } [ "IN: parser.tests GENERIC: blah ( x -- x )" eval( -- ) ] unit-test
{ } [ "IN: parser.tests GENERIC: blah ( x -- x )" eval( -- ) ; ] unit-test
{ } [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test
{ f } [ \ blah generic? ] unit-test
@ -637,7 +637,7 @@ EXCLUDE: qualified.tests.bar => x ;
[ ": 44 ( -- ) ;" <string-reader> "word identifier test" parse-stream ]
[ error>> lexer-error? ] must-fail-with
[ "GENERIC: 33 ( -- )" <string-reader> "generic identifier test" parse-stream ]
[ "GENERIC: 33 ( -- ) ;" <string-reader> "generic identifier test" parse-stream ]
[ error>> lexer-error? ] must-fail-with
{ t } [

2
core/parser/parser.factor
View File

@ -131,7 +131,7 @@ ERROR: classoid-expected object ;
symbol: quotation-parser
HOOK: parse-quotation quotation-parser ( -- quot )
HOOK: parse-quotation quotation-parser ( -- quot ) ;
M: f parse-quotation \ ] parse-until >quotation ;

Some files were not shown because too many files have changed in this diff Show More