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

First stage of stack effect declaration implementation

slava 2006-08-15 07:01:24 +00:00
parent fbddcdcca0
commit 56e19dbf14
104 changed files with 794 additions and 702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
TODO.FACTOR.txt
View File

@ -16,17 +16,13 @@
- the invalid recursion form case needs to be fixed, for inlines too
- graphical module manager tool
- see if alien calls can be made faster
========================================================================
+ ui:
- fix ui listener delay
- doc front page: document stack effect notation
- better doc for accumulate, link from tree
+ 0.85:
- fix ui listener delay
- we have trouble drawing rectangles
- the UI listener has a shitty design. perhaps it should not call out
to the real listener.
- remaining walker tasks:
- integrate walker with listener
- <input> handled by walker itself
@ -35,6 +31,32 @@
- error handling is still screwy
- continuation handling is also screwy
- keyboard commands
- editor:
- only redraw visible lines
- more efficient multi-line inserts
- editor should support stream output protocol
- slider needs to be modelized
- listener tab completion
- track individual method usages
- modularize core
- track module files and modification times, and a list of assets loaded
from that file
- 'changes' word, asks if files changed on disk from loaded modules
should be reloaded -- do this in the right order
- more compact relocation info
- UI dataflow visualizer
- loading the image should not exhaust nursery space
- problem if major gc happens during relocation
- in fact relocation should not cons at all
========================================================================
+ ui:
- figure out what goes in the .app and what doesn't
- should be possible to drop an image file on the .app to run it
- the UI listener has a shitty design. perhaps it should not call out
to the real listener.
- add-gadget, model-changed, set-model should compile
- shortcuts:
- find a listener
@ -50,9 +72,6 @@
- autoscroll
- page up/down
- search and replace
- only redraw visible lines
- more efficient multi-line inserts
- editor should support stream output protocol
- cocoa: windows are not updated while resizing
- grid slows down with 2000 lines
- ui uses too much cpu time idling
@ -64,31 +83,22 @@
- horizontal wheel scrolling
- polish OS X menu bar code
- variable width word wrap
- slider needs to be modelized
- structure editor
- listener tab completion
- loading space invaders slows the UI down
+ module system:
- generic 'define ( asset def -- )'
- track individual method usages
- C types should be words
- TYPEDEF: float { ... } { ... } ; ==> \ float T{ c-type ... } "c-type" swp
- TYPEDEF: float FTFloat ; ==> \ float \ FTFloat "c-type" swp
- make typedef aliasing explicit
- seeing a C struct word should show its def
- modularize core
- TUPLE: module files tests articles article main ;
- file out
- track module files and modification times, and a list of assets loaded
from that file
- 'changes' word, asks if files changed on disk from loaded modules
should be reloaded -- do this in the right order
+ compiler/ffi:
- more compact relocation info
- UI dataflow visualizer
- ppc64 backend
- we need to optimize [ dup array? [ array? ] [ array? ] if ]
- mac intel: struct returns from objc methods
@ -105,10 +115,8 @@
+ misc:
- loading the image should not exhaust nursery space
- compiler tests are not as reliable now
- problem if major gc happens during relocation
- in fact relocation should not cons at all
- compiler tests are not as reliable now because of try-compile usage
- we can just do [ t ] [ \ foo compiled? ] unit-test
- growable data heap
- incremental GC
- UDP
@ -124,5 +132,6 @@
[ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113
]
- prettier printing of hashtable literals, alists, cond, ...
- httpd search tools
- remaining HTML issues need fixing

32
library/bootstrap/image.factor
View File

@ -129,13 +129,13 @@ GENERIC: ' ( obj -- ptr )
dup length 1+ emit-fixnum
swap emit emit-seq ;
M: bignum ' ( bignum -- tagged )
M: bignum '
#! This can only emit 0, -1 and 1.
bignum-tag bignum-tag [ emit-bignum ] emit-object ;
( Fixnums )
M: fixnum ' ( n -- tagged )
M: fixnum '
#! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums.
dup most-negative-fixnum most-positive-fixnum between?
@ -143,7 +143,7 @@ M: fixnum ' ( n -- tagged )
( Floats )
M: float ' ( float -- tagged )
M: float '
float-tag float-tag [
align-here double>bits emit-64
] emit-object ;
@ -154,7 +154,7 @@ M: float ' ( float -- tagged )
: t, t t-offset fixup ;
M: f ' ( obj -- ptr )
M: f '
#! f is #define F RETAG(0,OBJECT_TYPE)
drop object-tag ;
@ -183,7 +183,7 @@ M: f ' ( obj -- ptr )
word-tag word-tag [ emit-seq ] emit-object
swap objects get set-hash ;
: word-error ( word msg -- )
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
@ -197,11 +197,11 @@ M: f ' ( obj -- ptr )
: fixup-words ( -- )
image get [ dup word? [ fixup-word ] when ] inject ;
M: word ' ( word -- pointer ) ;
M: word ' ;
( Wrappers )
M: wrapper ' ( wrapper -- pointer )
M: wrapper '
wrapped ' wrapper-tag wrapper-tag [ emit ] emit-object ;
( Ratios and complexes )
@ -209,10 +209,10 @@ M: wrapper ' ( wrapper -- pointer )
: emit-pair
[ [ emit ] 2apply ] emit-object ;
M: ratio ' ( c -- tagged )
M: ratio '
>fraction [ ' ] 2apply ratio-tag ratio-tag emit-pair ;
M: complex ' ( c -- tagged )
M: complex '
>rect [ ' ] 2apply complex-tag complex-tag emit-pair ;
( Strings )
@ -231,7 +231,7 @@ M: complex ' ( c -- tagged )
pack-string emit-chars
] emit-object ;
M: string ' ( string -- pointer )
M: string '
#! We pool strings so that each string is only written once
#! to the image
objects get [ emit-string ] cache ;
@ -249,24 +249,24 @@ M: string ' ( string -- pointer )
dup first transfer-word 0 pick set-nth
>tuple ;
M: tuple ' ( tuple -- pointer )
M: tuple '
transfer-tuple
objects get [ tuple>array tuple-type emit-array ] cache ;
M: array ' ( array -- pointer )
M: array '
array-type emit-array ;
M: quotation ' ( array -- pointer )
M: quotation '
quotation-type emit-array ;
M: vector ' ( vector -- pointer )
M: vector '
dup underlying ' swap length
vector-type object-tag [
emit-fixnum ( length )
emit ( array ptr )
] emit-object ;
M: sbuf ' ( sbuf -- pointer )
M: sbuf '
dup underlying ' swap length
sbuf-type object-tag [
emit-fixnum ( length )
@ -275,7 +275,7 @@ M: sbuf ' ( sbuf -- pointer )
( Hashes )
M: hashtable ' ( hashtable -- pointer )
M: hashtable '
[ hash-array ' ] keep
hashtable-type object-tag [
dup hash-count emit-fixnum

6
library/collections/arrays.factor
View File

@ -21,12 +21,12 @@ M: byte-array clone (clone) ;
M: byte-array length array-capacity ;
M: byte-array resize resize-array ;
: 1array ( x -- { x } ) 1 swap <array> ;
: 1array ( x -- array ) 1 swap <array> ;
: 2array ( x y -- { x y } )
: 2array ( x y -- array )
2 swap <array> [ 0 swap set-array-nth ] keep ;
: 3array ( x y z -- { x y z } )
: 3array ( x y z -- array )
3 swap <array>
[ 1 swap set-array-nth ] keep
[ 0 swap set-array-nth ] keep ;

2
library/collections/growable.factor
View File

@ -31,7 +31,7 @@ GENERIC: set-fill
TUPLE: bounds-error index seq ;
: bounds-error <bounds-error> throw ;
: bounds-error ( n seq -- * ) <bounds-error> throw ;
: growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline

33
library/collections/hashtables.factor
View File

@ -30,7 +30,7 @@ TUPLE: tombstone ;
: key@ ( key hash -- n )
hash-array 2dup hash@ (key@) ; inline
: if-key ( key hash true false -- | true: index key hash -- )
: if-key ( key hash true false -- ) | true ( index key hash -- )
>r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
: <hash-array> ( n -- array )
@ -75,10 +75,9 @@ TUPLE: tombstone ;
: (set-hash) ( value key hash -- )
2dup new-key@ swap
[ hash-array 2dup array-nth ] keep
( value key n hash-array old hash )
swap change-size set-nth-pair ; inline
: (each-pair) ( quot array i -- | quot: k v -- )
: (each-pair) ( quot array i -- ) | quot ( k v -- )
over array-capacity over eq? [
3drop
] [
@ -88,10 +87,10 @@ TUPLE: tombstone ;
] 3keep 2 fixnum+fast (each-pair)
] if ; inline
: each-pair ( array quot -- | quot: k v -- )
: each-pair ( array quot -- ) | quot ( k v -- )
swap 0 (each-pair) ; inline
: (all-pairs?) ( quot array i -- ? | quot: k v -- ? )
: (all-pairs?) ( quot array i -- ? ) | quot ( k v -- ? )
over array-capacity over eq? [
3drop t
] [
@ -106,7 +105,7 @@ TUPLE: tombstone ;
] if
] if ; inline
: all-pairs? ( array quot -- ? | quot: k v -- ? )
: all-pairs? ( array quot -- ? ) | quot ( k v -- ? )
swap 0 (all-pairs?) ; inline
: hash>seq ( i hash -- seq )
@ -189,17 +188,17 @@ IN: hashtables
[ length <hashtable> ] keep
[ first2 swap pick (set-hash) ] each ;
: hash-each ( hash quot -- | quot: k v -- )
: hash-each ( hash quot -- ) | quot ( k v -- )
>r hash-array r> each-pair ; inline
: hash-each-with ( obj hash quot -- | quot: obj k v -- )
: hash-each-with ( obj hash quot -- ) | quot ( obj k v -- )
swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
inline
: hash-all? ( hash quot -- | quot: k v -- ? )
: hash-all? ( hash quot -- ) | quot ( k v -- ? )
>r hash-array r> all-pairs? ; inline
: hash-all-with? ( obj hash quot -- | quot: obj k v -- ? )
: hash-all-with? ( obj hash quot -- ) | quot ( obj k v -- ? )
swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ;
inline
@ -209,7 +208,7 @@ IN: hashtables
>r swap hash* [ r> = ] [ r> 2drop f ] if
] hash-all-with? ;
: hash-subset ( hash quot -- hash | quot: k v -- ? )
: hash-subset ( hash quot -- hash ) | quot ( k v -- ? )
over hash-size <hashtable> rot [
2swap [
>r pick pick >r >r call [
@ -220,18 +219,18 @@ IN: hashtables
] 2keep
] hash-each nip ; inline
: hash-subset-with ( obj hash quot -- hash | quot: obj { k v } -- ? )
: hash-subset-with ( obj hash quot -- hash ) | quot ( obj pair -- ? )
swap
[ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
inline
M: hashtable clone ( hash -- hash )
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
: hashtable= ( hash hash -- ? )
2dup subhash? >r swap subhash? r> and ;
M: hashtable equal? ( obj hash -- ? )
M: hashtable equal?
{
{ [ over hashtable? not ] [ 2drop f ] }
{ [ 2dup [ hash-size ] 2apply number= not ] [ 2drop f ] }
@ -243,7 +242,7 @@ M: hashtable equal? ( obj hash -- ? )
hashcode >r hashcode -1 shift r> bitxor bitxor
] hash-each ;
M: hashtable hashcode ( hash -- n )
M: hashtable hashcode
dup hash-size 1 number=
[ hashtable-hashcode ] [ hash-size ] if ;
@ -293,14 +292,14 @@ IN: hashtables
: remove-all ( hash seq -- seq )
[ swap hash-member? not ] subset-with ;
: cache ( key hash quot -- value | quot: key -- value )
: cache ( key hash quot -- value ) | quot ( key -- value )
pick pick hash [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-hash
] if* ; inline
: map>hash ( seq quot -- hash | quot: key -- key value )
: map>hash ( seq quot -- hash ) | quot ( key -- key value )
over length <hashtable> rot
[ -rot [ >r call swap r> set-hash ] 2keep ] each nip ;
inline

6
library/collections/namespaces.factor
View File

@ -4,8 +4,8 @@ IN: kernel-internals
USING: vectors sequences ;
: namestack* ( -- ns ) 3 getenv { vector } declare ; inline
: >n ( namespace -- n:namespace ) namestack* push ;
: n> ( n:namespace -- namespace ) namestack* pop ;
: >n ( namespace -- ) namestack* push ;
: n> ( -- namespace ) namestack* pop ;
IN: namespaces
USING: arrays hashtables kernel kernel-internals math strings
@ -14,7 +14,7 @@ words ;
: namestack ( -- ns ) namestack* clone ; inline
: set-namestack ( ns -- ) >vector 3 setenv ; inline
: namespace ( -- namespace ) namestack* peek ;
: ndrop ( n:namespace -- ) namestack* pop* ;
: ndrop ( -- ) namestack* pop* ;
: global ( -- g ) 4 getenv { hashtable } declare ; inline
: get ( variable -- value ) namestack* hash-stack ;
: set ( value variable -- ) namespace set-hash ; inline

2
library/collections/queues.factor
View File

@ -34,7 +34,7 @@ C: queue ( -- queue ) ;
] if ;
TUPLE: empty-queue ;
: empty-queue <empty-queue> throw ;
: empty-queue ( -- * ) <empty-queue> throw ;
: deque ( queue -- obj )
dup queue-empty? [

18
library/collections/sequences-epilogue.factor
View File

@ -4,13 +4,13 @@ IN: sequences
USING: arrays errors generic kernel kernel-internals math
sequences-internals strings vectors words ;
: first2 ( { x y } -- x y )
: first2 ( seq -- x y )
1 swap bounds-check nip first2-unsafe ;
: first3 ( { x y z } -- x y z )
: first3 ( seq -- x y z )
2 swap bounds-check nip first3-unsafe ;
: first4 ( { x y z w } -- x y z w )
: first4 ( seq -- x y z w )
3 swap bounds-check nip first4-unsafe ;
M: object like drop ;
@ -129,21 +129,21 @@ M: object like drop ;
2dup [ length ] 2apply tuck number=
[ (mismatch) -1 number= ] [ 3drop f ] if ; inline
M: array equal? ( obj seq -- ? )
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
M: quotation equal? ( obj seq -- ? )
M: quotation equal?
over quotation? [ sequence= ] [ 2drop f ] if ;
M: sbuf equal? ( obj seq -- ? )
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
M: vector equal? ( obj seq -- ? )
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
UNION: sequence array string sbuf vector quotation ;
M: sequence hashcode ( hash -- n )
M: sequence hashcode
dup empty? [ drop 0 ] [ first hashcode ] if ;
IN: kernel
@ -155,7 +155,7 @@ M: object <=>
: depth ( -- n ) datastack length ;
TUPLE: no-cond ;
: no-cond <no-cond> throw ;
: no-cond ( -- * ) <no-cond> throw ;
: cond ( conditions -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ;

6
library/collections/sequences.factor
View File

@ -6,7 +6,7 @@ USING: errors generic kernel math math-internals strings vectors ;
GENERIC: length ( sequence -- n )
GENERIC: set-length ( n sequence -- )
GENERIC: nth ( n sequence -- obj )
GENERIC: set-nth ( value n sequence -- obj )
GENERIC: set-nth ( value n sequence -- )
GENERIC: thaw ( seq -- mutable-seq )
GENERIC: like ( seq seq -- seq )
@ -33,8 +33,8 @@ IN: sequences-internals
GENERIC: resize ( n seq -- seq )
! Unsafe sequence protocol for inner loops
GENERIC: nth-unsafe
GENERIC: set-nth-unsafe
GENERIC: nth-unsafe ( n sequence -- elt )
GENERIC: set-nth-unsafe ( elt n sequence -- )
M: object nth-unsafe nth ;
M: object set-nth-unsafe set-nth ;

4
library/collections/strings.factor
View File

@ -4,7 +4,7 @@ IN: strings
USING: generic kernel kernel-internals math sequences
sequences-internals ;
M: string equal? ( obj str -- ? )
M: string equal?
over string? [
over hashcode over hashcode number=
[ sequence= ] [ 2drop f ] if
@ -66,5 +66,5 @@ UNION: alpha Letter digit ;
M: string thaw drop SBUF" " clone ;
M: string like ( seq sbuf -- string )
M: string like
drop dup string? [ >string ] unless ;

12
library/collections/vectors.factor
View File

@ -4,17 +4,17 @@ IN: vectors
USING: arrays errors generic kernel kernel-internals math
math-internals sequences sequences-internals words ;
M: vector set-length ( len vec -- )
M: vector set-length
grow-length ;
M: vector nth-unsafe ( n vec -- obj ) underlying nth-unsafe ;
M: vector nth-unsafe underlying nth-unsafe ;
M: vector nth ( n vec -- obj ) bounds-check nth-unsafe ;
M: vector nth bounds-check nth-unsafe ;
M: vector set-nth-unsafe ( obj n vec -- )
M: vector set-nth-unsafe
underlying set-nth-unsafe ;
M: vector set-nth ( obj n vec -- )
M: vector set-nth
growable-check 2dup ensure set-nth-unsafe ;
: >vector ( seq -- vector )
@ -22,7 +22,7 @@ M: vector set-nth ( obj n vec -- )
M: object thaw drop V{ } clone ;
M: vector clone ( vector -- vector ) clone-growable ;
M: vector clone clone-growable ;
M: vector like
drop dup vector? [

30
library/collections/virtual-sequences.factor
View File

@ -8,20 +8,20 @@ TUPLE: reversed seq ;
: reversed@ reversed-seq [ length swap - 1- ] keep ; inline
M: reversed length ( seq -- n ) reversed-seq length ;
M: reversed length reversed-seq length ;
M: reversed nth ( n seq -- elt ) reversed@ nth ;
M: reversed nth reversed@ nth ;
M: reversed nth-unsafe ( n seq -- elt ) reversed@ nth-unsafe ;
M: reversed nth-unsafe reversed@ nth-unsafe ;
M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
M: reversed set-nth reversed@ set-nth ;
M: reversed set-nth-unsafe ( elt n seq -- )
M: reversed set-nth-unsafe
reversed@ set-nth-unsafe ;
M: reversed like ( seq reversed -- seq ) reversed-seq like ;
M: reversed like reversed-seq like ;
M: reversed thaw ( seq -- seq ) reversed-seq thaw ;
M: reversed thaw reversed-seq thaw ;
: reverse ( seq -- seq ) [ <reversed> ] keep like ;
@ -32,7 +32,7 @@ TUPLE: slice seq from to ;
dup slice-from swap slice-seq >r tuck + >r + r> r> ;
TUPLE: slice-error reason ;
: slice-error ( str -- ) <slice-error> throw ;
: slice-error ( str -- * ) <slice-error> throw ;
: check-slice ( from to seq -- )
pick 0 < [ "start < 0" slice-error ] when
@ -47,20 +47,20 @@ C: slice ( from to seq -- seq )
[ set-slice-to ] keep
[ set-slice-from ] keep ;
M: slice length ( range -- n )
M: slice length
dup slice-to swap slice-from - ;
: slice@ ( n slice -- n seq )
[ slice-from + ] keep slice-seq ; inline
M: slice nth ( n slice -- obj ) slice@ nth ;
M: slice nth slice@ nth ;
M: slice nth-unsafe ( n slice -- obj ) slice@ nth-unsafe ;
M: slice nth-unsafe slice@ nth-unsafe ;
M: slice set-nth ( obj n slice -- ) slice@ set-nth ;
M: slice set-nth slice@ set-nth ;
M: slice set-nth-unsafe ( n slice -- obj ) slice@ set-nth-unsafe ;
M: slice set-nth-unsafe slice@ set-nth-unsafe ;
M: slice like ( seq slice -- seq ) slice-seq like ;
M: slice like slice-seq like ;
M: slice thaw ( seq -- seq ) slice-seq thaw ;
M: slice thaw slice-seq thaw ;

6
library/compiler/alien/alien-callback.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: alien
USING: compiler errors generic hashtables inference inspector
kernel namespaces sequences strings words ;
kernel namespaces sequences strings words parser ;
TUPLE: alien-callback return parameters quot xt ;
C: alien-callback make-node ;
@ -15,7 +15,7 @@ TUPLE: alien-callback-error ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
\ alien-callback [ [ string object quotation ] [ alien ] ]
\ alien-callback [ string object quotation ] [ alien ] <effect>
"infer-effect" set-word-prop
\ alien-callback [
@ -55,7 +55,7 @@ TUPLE: alien-callback-error ;
%return
] generate-1 ;
M: alien-callback generate-node ( node -- )
M: alien-callback generate-node
end-basic-block compile-gc generate-callback iterate-next ;
M: alien-callback stack-reserve*

6
library/compiler/alien/alien-invoke.factor
View File

@ -4,7 +4,7 @@ IN: alien
USING: arrays assembler compiler compiler
errors generic hashtables inference inspector
io kernel kernel-internals math namespaces parser
prettyprint sequences strings words ;
prettyprint sequences strings words parser ;
TUPLE: alien-invoke library function return parameters ;
C: alien-invoke make-node ;
@ -22,7 +22,7 @@ TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
pick pick <alien-invoke-error> throw ;
\ alien-invoke [ [ string object string object ] [ ] ]
\ alien-invoke [ string object string object ] [ ] <effect>
"infer-effect" set-word-prop
\ alien-invoke [
@ -60,7 +60,7 @@ TUPLE: alien-invoke-error library symbol ;
alien-invoke-parameters stack-space %cleanup
] if ;
M: alien-invoke generate-node ( node -- )
M: alien-invoke generate-node
end-basic-block compile-gc
dup alien-invoke-parameters objects>registers
dup alien-invoke-dlsym %alien-invoke

2
library/compiler/alien/aliens.factor
View File

@ -8,7 +8,7 @@ sequences ;
UNION: c-ptr byte-array alien ;
M: alien equal? ( obj obj -- ? )
M: alien equal?
over alien? [
2dup [ expired? ] 2apply 2dup or [
2swap 2drop

3
library/compiler/alien/objc/utilities.factor
View File

@ -119,7 +119,8 @@ H{ } clone objc-methods set-global
\ (send) [ pop-literal nip infer-send ] "infer" set-word-prop
\ (send) [ [ object object ] [ ] ] "infer-effect" set-word-prop
\ (send) [ object object ] [ ] <effect>
"infer-effect" set-word-prop
: send ( ... selector -- ... ) f (send) ; inline

16
library/compiler/generator/generator.factor
View File

@ -66,14 +66,14 @@ GENERIC: generate-node ( node -- )
[ [ generate-nodes ] with-node-iterator ] generate-1 ;
! node
M: node generate-node ( node -- next ) drop iterate-next ;
M: node generate-node drop iterate-next ;
! #label
: generate-call ( label -- next )
end-basic-block
tail-call? [ %jump f ] [ %call iterate-next ] if ;
M: #label generate-node ( node -- next )
M: #label generate-node
dup node-param dup generate-call >r
swap node-child generate r> ;
@ -87,7 +87,7 @@ M: #label generate-node ( node -- next )
r> r> end-false-branch resolve-label generate-nodes
] keep resolve-label iterate-next ;
M: #if generate-node ( node -- next )
M: #if generate-node
[
end-basic-block
<label> dup %jump-t
@ -123,7 +123,7 @@ M: #if generate-node ( node -- next )
drop r> if>boolean-intrinsic iterate-next
] if ;
M: #call generate-node ( node -- next )
M: #call generate-node
{
{ [ dup if-intrinsic ] [ do-if-intrinsic ] }
{ [ dup intrinsic ] [ intrinsic call iterate-next ] }
@ -131,7 +131,7 @@ M: #call generate-node ( node -- next )
} cond ;
! #call-label
M: #call-label generate-node ( node -- next )
M: #call-label generate-node
node-param generate-call ;
! #dispatch
@ -150,7 +150,7 @@ M: #call-label generate-node ( node -- next )
dup %jump-label
] each resolve-label ;
M: #dispatch generate-node ( node -- next )
M: #dispatch generate-node
#! The parameter is a list of nodes, each one is a branch to
#! take in case the top of stack has that type.
dispatch-head dispatch-body iterate-next ;
@ -164,7 +164,7 @@ UNION: immediate fixnum POSTPONE: f ;
[ f spec>vreg [ load-literal ] keep ] map
phantom-d get phantom-append ;
M: #push generate-node ( #push -- )
M: #push generate-node
generate-push iterate-next ;
! #shuffle
@ -193,7 +193,7 @@ M: #push generate-node ( #push -- )
[ shuffle* ] keep adjust-shuffle
(template-outputs) ;
M: #shuffle generate-node ( #shuffle -- )
M: #shuffle generate-node
node-shuffle phantom-shuffle iterate-next ;
! #return

2
library/compiler/generator/templates.factor
View File

@ -87,7 +87,7 @@ M: phantom-callstack finalize-height
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom
[ delegate cut* swap ] keep set-delegate ;
SYMBOL: phantom-d

5
library/compiler/generator/xt.factor
View File

@ -21,8 +21,7 @@ C: label ( -- label ) ;
SYMBOL: compiled-xts
: save-xt ( word xt -- )
over changed-words get remove-hash
swap compiled-xts get set-hash ;
swap dup unchanged-word compiled-xts get set-hash ;
SYMBOL: literal-table
@ -82,7 +81,7 @@ SYMBOL: label-table
: compiling? ( word -- ? )
{
{ [ dup compiled-xts get hash-member? ] [ drop t ] }
{ [ dup changed-words get hash-member? ] [ drop f ] }
{ [ dup word-changed? ] [ drop f ] }
{ [ t ] [ compiled? ] }
} cond ;

6
library/compiler/inference/dataflow.factor
View File

@ -28,9 +28,9 @@ M: node equal? eq? ;
: set-node-out-r node-shuffle set-shuffle-out-r ;
: empty-node f { } { } { } { } ;
: param-node ( label) { } { } { } { } ;
: in-node ( inputs) >r f r> { } { } { } ;
: out-node ( outputs) >r f { } r> { } { } ;
: param-node { } { } { } { } ;
: in-node >r f r> { } { } { } ;
: out-node >r f { } r> { } { } ;
: meta-d-node meta-d get clone in-node ;
: d-tail ( n -- list )

25
library/compiler/inference/inference.factor
View File

@ -11,11 +11,11 @@ SYMBOL: base-case-continuation
TUPLE: inference-error message rstate data-stack call-stack ;
: inference-error ( msg -- )
: inference-error ( msg -- * )
recursive-state get meta-d get meta-r get
<inference-error> throw ;
M: object value-literal ( value -- )
M: object value-literal
"A literal value was expected where a computed value was found" inference-error ;
! Word properties that affect inference:
@ -42,7 +42,7 @@ SYMBOL: d-in
: ensure-values ( n -- )
meta-d [ add-inputs ] change d-in [ + ] change ;
: effect ( -- { in# out# } )
: short-effect ( -- { in# out# } )
#! After inference is finished, collect information.
d-in get meta-d get length 2array ;
@ -50,6 +50,13 @@ SYMBOL: d-in
! stack height is irrelevant and the branch will always unify?
SYMBOL: terminated?
: current-effect ( -- effect )
#! After inference is finished, collect information.
d-in get meta-d get length <effect>
terminated? get over set-effect-terminated? ;
SYMBOL: recorded
: init-inference ( recursive-state -- )
terminated? off
V{ } clone meta-r set
@ -76,9 +83,9 @@ M: wrapper apply-object wrapped apply-literal ;
GENERIC: infer-quot
M: f infer-quot ( f -- ) drop ;
M: f infer-quot drop ;
M: quotation infer-quot ( quot -- )
M: quotation infer-quot
#! Recursive calls to this word are made for nested
#! quotations.
[ apply-object terminated? get not ] all? drop ;
@ -96,17 +103,23 @@ M: quotation infer-quot ( quot -- )
] unless ;
: with-infer ( quot -- )
[
[
base-case-continuation off
{ } recursive-state set
V{ } clone recorded set
f init-inference
call
check-return
] [
recorded get dup . [ f "infer-effect" set-word-prop ] each
rethrow
] recover
] with-scope ;
: infer ( quot -- effect )
#! Stack effect of a quotation.
[ infer-quot effect ] with-infer ;
[ infer-quot short-effect ] with-infer ;
: (dataflow) ( quot -- dataflow )
infer-quot f #return node, dataflow-graph get ;

335
library/compiler/inference/known-words.factor
View File

@ -10,49 +10,49 @@ sequences strings vectors words prettyprint ;
dup #declare [ >r length d-tail r> set-node-in-d ] keep
node,
] "infer" set-word-prop
\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
\ declare { object } { } <effect> "infer-effect" set-word-prop
\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum< { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
\ fixnum< t "foldable" set-word-prop
\ fixnum<= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum<= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
\ fixnum<= t "foldable" set-word-prop
\ fixnum> [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum> { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
\ fixnum> t "foldable" set-word-prop
\ fixnum>= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
\ fixnum>= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
\ fixnum>= t "foldable" set-word-prop
\ eq? [ [ object object ] [ object ] ] "infer-effect" set-word-prop
\ eq? { object object } { object } <effect> "infer-effect" set-word-prop
\ eq? t "foldable" set-word-prop
! Primitive combinators
\ call [ [ object ] [ ] ] "infer-effect" set-word-prop
\ call { object } { } <effect> "infer-effect" set-word-prop
\ call [ pop-literal infer-quot-value ] "infer" set-word-prop
\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
\ execute { word } { } <effect> "infer-effect" set-word-prop
\ execute [
pop-literal unit infer-quot-value
] "infer" set-word-prop
\ if [ [ object object object ] [ ] ] "infer-effect" set-word-prop
\ if { object object object } { } <effect> "infer-effect" set-word-prop
\ if [
2 #drop node, pop-d pop-d swap 2array
#if pop-d drop infer-branches
] "infer" set-word-prop
\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
\ cond { object } { } <effect> "infer-effect" set-word-prop
\ cond [
pop-literal <reversed>
[ no-cond ] swap alist>quot infer-quot-value
] "infer" set-word-prop
\ dispatch [ [ fixnum array ] [ ] ] "infer-effect" set-word-prop
\ dispatch { fixnum array } { } <effect> "infer-effect" set-word-prop
\ dispatch [
pop-literal nip [ <value> ] map
@ -60,343 +60,340 @@ sequences strings vectors words prettyprint ;
] "infer" set-word-prop
! Non-standard control flow
\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
\ throw [
\ throw dup "infer-effect" word-prop consume/produce
terminate
] "infer" set-word-prop
\ throw { object } { } <effect>
t over set-effect-terminated?
"infer-effect" set-word-prop
! Stack effects for all primitives
\ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
\ <vector> { integer } { vector } <effect> "infer-effect" set-word-prop
\ rehash-string [ [ string ] [ ] ] "infer-effect" set-word-prop
\ rehash-string { string } { } <effect> "infer-effect" set-word-prop
\ <sbuf> [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop
\ <sbuf> { integer } { sbuf } <effect> "infer-effect" set-word-prop
\ >fixnum [ [ real ] [ fixnum ] ] "infer-effect" set-word-prop
\ >fixnum { real } { fixnum } <effect> "infer-effect" set-word-prop
\ >fixnum t "foldable" set-word-prop
\ >bignum [ [ real ] [ bignum ] ] "infer-effect" set-word-prop
\ >bignum { real } { bignum } <effect> "infer-effect" set-word-prop
\ >bignum t "foldable" set-word-prop
\ >float [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ >float { real } { float } <effect> "infer-effect" set-word-prop
\ >float t "foldable" set-word-prop
\ (fraction>) [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ (fraction>) { integer integer } { rational } <effect> "infer-effect" set-word-prop
\ (fraction>) t "foldable" set-word-prop
\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
\ string>float { string } { float } <effect> "infer-effect" set-word-prop
\ string>float t "foldable" set-word-prop
\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
\ float>string { float } { string } <effect> "infer-effect" set-word-prop
\ float>string t "foldable" set-word-prop
\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
\ float>bits { real } { integer } <effect> "infer-effect" set-word-prop
\ float>bits t "foldable" set-word-prop
\ double>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
\ double>bits { real } { integer } <effect> "infer-effect" set-word-prop
\ double>bits t "foldable" set-word-prop
\ bits>float [ [ integer ] [ float ] ] "infer-effect" set-word-prop
\ bits>float { integer } { float } <effect> "infer-effect" set-word-prop
\ bits>float t "foldable" set-word-prop
\ bits>double [ [ integer ] [ float ] ] "infer-effect" set-word-prop
\ bits>double { integer } { float } <effect> "infer-effect" set-word-prop
\ bits>double t "foldable" set-word-prop
\ <complex> [ [ real real ] [ number ] ] "infer-effect" set-word-prop
\ <complex> { real real } { number } <effect> "infer-effect" set-word-prop
\ <complex> t "foldable" set-word-prop
\ fixnum+ [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum+ { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
\ fixnum+ t "foldable" set-word-prop
\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum+fast t "foldable" set-word-prop
\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum- { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
\ fixnum- t "foldable" set-word-prop
\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-fast t "foldable" set-word-prop
\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum* { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
\ fixnum* t "foldable" set-word-prop
\ fixnum/i [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum/i { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
\ fixnum/i t "foldable" set-word-prop
\ fixnum/f [ [ fixnum fixnum ] [ float ] ] "infer-effect" set-word-prop
\ fixnum/f { fixnum fixnum } { float } <effect> "infer-effect" set-word-prop
\ fixnum/f t "foldable" set-word-prop
\ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-mod t "foldable" set-word-prop
\ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] "infer-effect" set-word-prop
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "infer-effect" set-word-prop
\ fixnum/mod t "foldable" set-word-prop
\ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-bitand t "foldable" set-word-prop
\ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-bitor t "foldable" set-word-prop
\ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-bitxor t "foldable" set-word-prop
\ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
\ fixnum-bitnot { fixnum } { fixnum } <effect> "infer-effect" set-word-prop
\ fixnum-bitnot t "foldable" set-word-prop
\ fixnum-shift [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum-shift { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
\ fixnum-shift t "foldable" set-word-prop
\ bignum= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ bignum= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
\ bignum= t "foldable" set-word-prop
\ bignum+ [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum+ { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum+ t "foldable" set-word-prop
\ bignum- [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum- { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum- t "foldable" set-word-prop
\ bignum* [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum* { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum* t "foldable" set-word-prop
\ bignum/i [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum/i { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum/i t "foldable" set-word-prop
\ bignum/f [ [ bignum bignum ] [ float ] ] "infer-effect" set-word-prop
\ bignum/f { bignum bignum } { float } <effect> "infer-effect" set-word-prop
\ bignum/f t "foldable" set-word-prop
\ bignum-mod [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-mod { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-mod t "foldable" set-word-prop
\ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] "infer-effect" set-word-prop
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "infer-effect" set-word-prop
\ bignum/mod t "foldable" set-word-prop
\ bignum-bitand [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-bitand { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-bitand t "foldable" set-word-prop
\ bignum-bitor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-bitor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-bitor t "foldable" set-word-prop
\ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-bitxor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-bitxor t "foldable" set-word-prop
\ bignum-bitnot [ [ bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-bitnot { bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-bitnot t "foldable" set-word-prop
\ bignum-shift [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
\ bignum-shift { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
\ bignum-shift t "foldable" set-word-prop
\ bignum< [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ bignum< { bignum bignum } { object } <effect> "infer-effect" set-word-prop
\ bignum< t "foldable" set-word-prop
\ bignum<= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ bignum<= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
\ bignum<= t "foldable" set-word-prop
\ bignum> [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ bignum> { bignum bignum } { object } <effect> "infer-effect" set-word-prop
\ bignum> t "foldable" set-word-prop
\ bignum>= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
\ bignum>= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
\ bignum>= t "foldable" set-word-prop
\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float+ { float float } { float } <effect> "infer-effect" set-word-prop
\ float+ t "foldable" set-word-prop
\ float- [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float- { float float } { float } <effect> "infer-effect" set-word-prop
\ float- t "foldable" set-word-prop
\ float* [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float* { float float } { float } <effect> "infer-effect" set-word-prop
\ float* t "foldable" set-word-prop
\ float/f [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float/f { float float } { float } <effect> "infer-effect" set-word-prop
\ float/f t "foldable" set-word-prop
\ float< [ [ float float ] [ object ] ] "infer-effect" set-word-prop
\ float< { float float } { object } <effect> "infer-effect" set-word-prop
\ float< t "foldable" set-word-prop
\ float-mod [ [ float float ] [ float ] ] "infer-effect" set-word-prop
\ float-mod { float float } { float } <effect> "infer-effect" set-word-prop
\ float-mod t "foldable" set-word-prop
\ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
\ float<= { float float } { object } <effect> "infer-effect" set-word-prop
\ float<= t "foldable" set-word-prop
\ float> [ [ float float ] [ object ] ] "infer-effect" set-word-prop
\ float> { float float } { object } <effect> "infer-effect" set-word-prop
\ float> t "foldable" set-word-prop
\ float>= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
\ float>= { float float } { object } <effect> "infer-effect" set-word-prop
\ float>= t "foldable" set-word-prop
\ facos [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ facos { real } { float } <effect> "infer-effect" set-word-prop
\ facos t "foldable" set-word-prop
\ fasin [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fasin { real } { float } <effect> "infer-effect" set-word-prop
\ fasin t "foldable" set-word-prop
\ fatan [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fatan { real } { float } <effect> "infer-effect" set-word-prop
\ fatan t "foldable" set-word-prop
\ fatan2 [ [ real real ] [ float ] ] "infer-effect" set-word-prop
\ fatan2 { real real } { float } <effect> "infer-effect" set-word-prop
\ fatan2 t "foldable" set-word-prop
\ fcos [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fcos { real } { float } <effect> "infer-effect" set-word-prop
\ fcos t "foldable" set-word-prop
\ fexp [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fexp { real } { float } <effect> "infer-effect" set-word-prop
\ fexp t "foldable" set-word-prop
\ fcosh [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fcosh { real } { float } <effect> "infer-effect" set-word-prop
\ fcosh t "foldable" set-word-prop
\ flog [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ flog { real } { float } <effect> "infer-effect" set-word-prop
\ flog t "foldable" set-word-prop
\ fpow [ [ real real ] [ float ] ] "infer-effect" set-word-prop
\ fpow { real real } { float } <effect> "infer-effect" set-word-prop
\ fpow t "foldable" set-word-prop
\ fsin [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fsin { real } { float } <effect> "infer-effect" set-word-prop
\ fsin t "foldable" set-word-prop
\ fsinh [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fsinh { real } { float } <effect> "infer-effect" set-word-prop
\ fsinh t "foldable" set-word-prop
\ fsqrt [ [ real ] [ float ] ] "infer-effect" set-word-prop
\ fsqrt { real } { float } <effect> "infer-effect" set-word-prop
\ fsqrt t "foldable" set-word-prop
\ (word) [ [ object object ] [ word ] ] "infer-effect" set-word-prop
\ (word) { object object } { word } <effect> "infer-effect" set-word-prop
\ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
\ compiled? [ [ word ] [ object ] ] "infer-effect" set-word-prop
\ update-xt { word } { } <effect> "infer-effect" set-word-prop
\ compiled? { word } { object } <effect> "infer-effect" set-word-prop
\ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop
\ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop
\ stat [ [ string ] [ object ] ] "infer-effect" set-word-prop
\ (directory) [ [ string ] [ array ] ] "infer-effect" set-word-prop
\ gc [ [ integer ] [ ] ] "infer-effect" set-word-prop
\ gc-time [ [ ] [ integer ] ] "infer-effect" set-word-prop
\ save-image [ [ string ] [ ] ] "infer-effect" set-word-prop
\ exit [ [ integer ] [ ] ] "infer-effect" set-word-prop
\ room [ [ ] [ integer integer integer integer array ] ] "infer-effect" set-word-prop
\ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop
\ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop
\ getenv { fixnum } { object } <effect> "infer-effect" set-word-prop
\ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
\ stat { string } { object } <effect> "infer-effect" set-word-prop
\ (directory) { string } { array } <effect> "infer-effect" set-word-prop
\ gc { integer } { } <effect> "infer-effect" set-word-prop
\ gc-time { } { integer } <effect> "infer-effect" set-word-prop
\ save-image { string } { } <effect> "infer-effect" set-word-prop
\ exit { integer } { } <effect> "infer-effect" set-word-prop
\ room { } { integer integer integer integer array } <effect> "infer-effect" set-word-prop
\ os-env { string } { object } <effect> "infer-effect" set-word-prop
\ millis { } { integer } <effect> "infer-effect" set-word-prop
\ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
\ type { object } { fixnum } <effect> "infer-effect" set-word-prop
\ type t "foldable" set-word-prop
\ tag [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
\ tag { object } { fixnum } <effect> "infer-effect" set-word-prop
\ tag t "foldable" set-word-prop
\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
\ cwd { } { string } <effect> "infer-effect" set-word-prop
\ cd { string } { } <effect> "infer-effect" set-word-prop
\ add-compiled-block [ [ vector vector vector integer ] [ integer ] ] "infer-effect" set-word-prop
\ add-compiled-block { vector vector vector integer } { integer } <effect> "infer-effect" set-word-prop
\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
\ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop
\ dlopen { string } { dll } <effect> "infer-effect" set-word-prop
\ dlsym { string object } { integer } <effect> "infer-effect" set-word-prop
\ dlclose { dll } { } <effect> "infer-effect" set-word-prop
\ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
\ <byte-array> { integer } { byte-array } <effect> "infer-effect" set-word-prop
\ <displaced-alien> [ [ integer c-ptr ] [ c-ptr ] ] "infer-effect" set-word-prop
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "infer-effect" set-word-prop
\ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ alien-signed-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-signed-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-unsigned-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-unsigned-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-signed-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-signed-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-signed-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-unsigned-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-unsigned-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-signed-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-signed-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-signed-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-unsigned-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-unsigned-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-signed-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-signed-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-signed-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-unsigned-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-unsigned-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-signed-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-signed-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-signed-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-unsigned-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
\ set-alien-unsigned-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
\ set-alien-float [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
\ set-alien-float { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
\ set-alien-double { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
\ alien-double { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
\ alien>char-string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
\ alien>char-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
\ string>char-alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
\ string>char-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
\ alien>u16-string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
\ alien>u16-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
\ string>u16-alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
\ string>u16-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
\ string>memory { string integer } { } <effect> "infer-effect" set-word-prop
\ memory>string { integer integer } { string } <effect> "infer-effect" set-word-prop
\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
\ alien-address { alien } { integer } <effect> "infer-effect" set-word-prop
\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop
\ slot { object fixnum } { object } <effect> "infer-effect" set-word-prop
\ set-slot [ [ object object fixnum ] [ ] ] "infer-effect" set-word-prop
\ set-slot { object object fixnum } { } <effect> "infer-effect" set-word-prop
\ integer-slot [ [ object fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ integer-slot { object fixnum } { integer } <effect> "infer-effect" set-word-prop
\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
\ set-integer-slot { integer object fixnum } { } <effect> "infer-effect" set-word-prop
\ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
\ char-slot { fixnum object } { fixnum } <effect> "infer-effect" set-word-prop
\ set-char-slot [ [ fixnum fixnum object ] [ ] ] "infer-effect" set-word-prop
\ resize-array [ [ integer array ] [ array ] ] "infer-effect" set-word-prop
\ resize-string [ [ integer string ] [ string ] ] "infer-effect" set-word-prop
\ set-char-slot { fixnum fixnum object } { } <effect> "infer-effect" set-word-prop
\ resize-array { integer array } { array } <effect> "infer-effect" set-word-prop
\ resize-string { integer string } { string } <effect> "infer-effect" set-word-prop
\ (hashtable) [ [ ] [ hashtable ] ] "infer-effect" set-word-prop
\ (hashtable) { } { hashtable } <effect> "infer-effect" set-word-prop
\ <array> [ [ integer object ] [ array ] ] "infer-effect" set-word-prop
\ <array> { integer object } { array } <effect> "infer-effect" set-word-prop
\ <tuple> [ [ integer word ] [ tuple ] ] "infer-effect" set-word-prop
\ <tuple> { integer word } { tuple } <effect> "infer-effect" set-word-prop
\ begin-scan [ [ ] [ ] ] "infer-effect" set-word-prop
\ next-object [ [ ] [ object ] ] "infer-effect" set-word-prop
\ end-scan [ [ ] [ ] ] "infer-effect" set-word-prop
\ begin-scan { } { } <effect> "infer-effect" set-word-prop
\ next-object { } { object } <effect> "infer-effect" set-word-prop
\ end-scan { } { } <effect> "infer-effect" set-word-prop
\ size [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
\ size { object } { fixnum } <effect> "infer-effect" set-word-prop
\ die [ [ ] [ ] ] "infer-effect" set-word-prop
\ fopen [ [ string string ] [ alien ] ] "infer-effect" set-word-prop
\ fgetc [ [ alien ] [ object ] ] "infer-effect" set-word-prop
\ fwrite [ [ string alien ] [ ] ] "infer-effect" set-word-prop
\ fflush [ [ alien ] [ ] ] "infer-effect" set-word-prop
\ fclose [ [ alien ] [ ] ] "infer-effect" set-word-prop
\ expired? [ [ object ] [ object ] ] "infer-effect" set-word-prop
\ die { } { } <effect> "infer-effect" set-word-prop
\ fopen { string string } { alien } <effect> "infer-effect" set-word-prop
\ fgetc { alien } { object } <effect> "infer-effect" set-word-prop
\ fwrite { string alien } { } <effect> "infer-effect" set-word-prop
\ fflush { alien } { } <effect> "infer-effect" set-word-prop
\ fclose { alien } { } <effect> "infer-effect" set-word-prop
\ expired? { object } { object } <effect> "infer-effect" set-word-prop
\ <wrapper> [ [ object ] [ wrapper ] ] "infer-effect" set-word-prop
\ <wrapper> { object } { wrapper } <effect> "infer-effect" set-word-prop
\ <wrapper> t "foldable" set-word-prop
\ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop
\ (clone) { object } { object } <effect> "infer-effect" set-word-prop
\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop
\ array>tuple { array } { tuple } <effect> "infer-effect" set-word-prop
\ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop
\ tuple>array { tuple } { array } <effect> "infer-effect" set-word-prop
\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
\ array>vector { array } { vector } <effect> "infer-effect" set-word-prop
\ finalize-compile [ [ array ] [ ] ] "infer-effect" set-word-prop
\ finalize-compile { array } { } <effect> "infer-effect" set-word-prop
\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
\ <string> { integer integer } { string } <effect> "infer-effect" set-word-prop
\ <quotation> [ [ integer ] [ quotation ] ] "infer-effect" set-word-prop
\ <quotation> { integer } { quotation } <effect> "infer-effect" set-word-prop

2
library/compiler/inference/shuffle.factor
View File

@ -51,7 +51,7 @@ TUPLE: shuffle in-d in-r out-d out-r ;
#! the shuffle.
[ split-shuffle ] keep shuffle* join-shuffle ;
M: shuffle clone ( shuffle -- shuffle )
M: shuffle clone
[ shuffle-in-d clone ] keep
[ shuffle-in-r clone ] keep
[ shuffle-out-d clone ] keep

5
library/compiler/inference/stack.factor
View File

@ -1,6 +1,6 @@
IN: inference
USING: arrays generic interpreter kernel math namespaces
sequences words ;
sequences words parser ;
: infer-shuffle-inputs ( shuffle node -- )
>r dup shuffle-in-d length swap shuffle-in-r length r>
@ -22,8 +22,7 @@ sequences words ;
node, ;
: shuffle>effect ( shuffle -- effect )
dup shuffle-in-d [ drop object ] map
swap shuffle-out-d [ drop object ] map 2array ;
dup shuffle-in-d swap shuffle-out-d <effect> ;
: define-shuffle ( word shuffle -- )
[ shuffle>effect "infer-effect" set-word-prop ] 2keep

89
library/compiler/inference/words.factor
View File

@ -18,16 +18,16 @@ IN: inference
#! Add a node to the dataflow graph that consumes and
#! produces a number of values.
swap #call
over first length over consume-values
swap second length over produce-values
node, ;
over effect-in length over consume-values
over effect-out length over produce-values
node, effect-terminated? [ terminate ] when ;
: no-effect ( word -- )
"Stack effect inference of the word " swap word-name
" was already attempted, and failed" append3
inference-error ;
TUPLE: rstate label base-case? ;
TUPLE: rstate label count ;
: nest-node ( -- ) #entry node, ;
@ -35,10 +35,10 @@ TUPLE: rstate label base-case? ;
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
: add-recursive-state ( word label base-case -- )
: add-recursive-state ( word label count -- )
<rstate> 2array recursive-state [ swap add ] change ;
: inline-block ( word base-case -- node-block variables )
: inline-block ( word count -- node-block variables )
[
copy-inference nest-node
>r gensym 2dup r> add-recursive-state
@ -52,9 +52,9 @@ TUPLE: rstate label base-case? ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* ( label node -- ) 2drop ;
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion* ( label node -- )
M: #call-label collect-recursion*
tuck node-param eq? [ node-in-d , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
@ -84,15 +84,15 @@ M: #call-label collect-recursion* ( label node -- )
#! closure under recursive value substitution.
#! If the block does not call itself, there is no point in
#! having the block node in the IR. Just add its contents.
dup f inline-block over recursive-label? [
dup 0 inline-block over recursive-label? [
meta-d get >r
drop join-values f inline-block apply-infer
drop join-values 0 inline-block apply-infer
r> over set-node-in-d node,
] [
apply-infer node-child node-successor splice-node drop
] if ;
: infer-compound ( word base-case -- terminates? effect )
: infer-compound ( word count -- effect )
#! Infer a word's stack effect in a separate inferencer
#! instance. Outputs a true boolean if the word terminates
#! control flow by throwing an exception or restoring a
@ -100,22 +100,29 @@ M: #call-label collect-recursion* ( label node -- )
[
recursive-state get init-inference
over >r inline-block nip
[ terminated? get effect ] bind r>
] with-scope over consume/produce over [ terminate ] when ;
[ current-effect ] bind r>
] with-scope over consume/produce ;
GENERIC: apply-word
M: object apply-word ( word -- )
M: object apply-word
#! A primitive with an unknown stack effect.
no-effect ;
: save-effect ( word terminates effect prop -- )
rot [ 3drop ] [ set-word-prop ] if ;
TUPLE: effect-error word effect ;
M: compound apply-word ( word -- )
: effect-error ( -- * ) <effect-error> throw ;
: check-effect ( word effect -- )
over recorded get push
dup pick "declared-effect" word-prop dup
[ effect<= [ effect-error ] unless ] [ 2drop ] if
"infer-effect" set-word-prop ;
M: compound apply-word
#! Infer a compound word's stack effect.
[
dup f infer-compound "infer-effect" save-effect
dup 0 infer-compound check-effect
] [
swap t "no-effect" set-word-prop rethrow
] recover ;
@ -124,7 +131,7 @@ M: compound apply-word ( word -- )
dup "no-effect" word-prop [ no-effect ] when
dup "infer-effect" word-prop [
over "infer" word-prop [
swap first length ensure-values call drop
swap effect-in length ensure-values call drop
] [
consume/produce
] if*
@ -132,46 +139,28 @@ M: compound apply-word ( word -- )
apply-word
] if* ;
M: word apply-object ( word -- )
apply-default ;
M: word apply-object apply-default ;
M: symbol apply-object ( word -- )
apply-literal ;
M: symbol apply-object apply-literal ;
: inline-base-case ( word label -- )
meta-d get clone >r over t inline-block apply-infer drop
[ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
: declared-effect ( word -- effect )
dup "declared-effect" word-prop [ ] [
"The recursive word " swap word-name
" does not declare a stack effect" append3
inference-error
] ?if ;
: base-case ( word label -- )
over "inline" word-prop [
inline-base-case
] [
drop dup t infer-compound "base-case" save-effect
] if ;
: recursive-word ( word rstate -- )
: recursive-effect ( word -- effect )
#! Handle a recursive call, by either applying a previously
#! inferred base case, or raising an error. If the recursive
#! call is to a local block, emit a label call node.
over "infer-effect" word-prop [
nip consume/produce
] [
over "base-case" word-prop [
nip consume/produce
] [
dup rstate-base-case? [
notify-base-case
] [
rstate-label base-case
] if
] if*
] if* ;
dup "infer-effect" word-prop [ ] [ declared-effect ] if ;
M: compound apply-object ( word -- )
M: compound apply-object
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get <reversed> assoc [
recursive-word
dup recursive-effect consume/produce
] [
dup "inline" word-prop
[ inline-closure ] [ apply-default ] if
] if* ;
] if ;

7
library/compiler/optimizer/call-optimizers.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays errors generic hashtables inference kernel
math math-internals sequences words ;
math math-internals sequences words parser ;
! A system for associating dataflow optimizers with words.
@ -58,7 +58,8 @@ math math-internals sequences words ;
: useless-coerce? ( node -- )
dup 0 node-class#
swap node-param "infer-effect" word-prop second first eq? ;
swap node-param "infer-effect" word-prop effect-out first
eq? ;
{ >fixnum >bignum >float } [
{
@ -171,7 +172,7 @@ SYMBOL: @
{ { @ @ } [ 2drop t ] }
} define-identities
M: #call optimize-node* ( node -- node/t )
M: #call optimize-node*
{
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity nip ] [ apply-identities ] }

26
library/compiler/optimizer/class-infer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays generic hashtables inference kernel
kernel-internals math namespaces sequences words ;
kernel-internals math namespaces sequences words parser ;
! Infer possible classes of values in a dataflow IR.
: node-class# ( node n -- class )
@ -21,7 +21,7 @@ SYMBOL: ties
GENERIC: apply-tie ( tie -- )
M: f apply-tie ( f -- ) drop ;
M: f apply-tie drop ;
TUPLE: class-tie value class ;
@ -29,7 +29,7 @@ TUPLE: class-tie value class ;
2dup swap <class-tie> ties get hash [ apply-tie ] when*
value-classes get set-hash ;
M: class-tie apply-tie ( tie -- )
M: class-tie apply-tie
dup class-tie-class swap class-tie-value
set-value-class* ;
@ -40,18 +40,18 @@ TUPLE: literal-tie value literal ;
2dup swap <literal-tie> ties get hash [ apply-tie ] when*
value-literals get set-hash ;
M: literal-tie apply-tie ( tie -- )
M: literal-tie apply-tie
dup literal-tie-literal swap literal-tie-value
set-value-literal* ;
GENERIC: infer-classes* ( node -- )
M: node infer-classes* ( node -- ) drop ;
M: node infer-classes* drop ;
! For conditionals, a map of child node # --> possibility
GENERIC: child-ties ( node -- seq )
M: node child-ties ( node -- seq )
M: node child-ties
node-children length f <array> ;
: value-class* ( value -- class )
@ -119,27 +119,27 @@ M: node child-ties ( node -- seq )
dup node-param "output-classes" word-prop [
call
] [
node-param "infer-effect" word-prop second
dup integer? [ drop f ] when
node-param "infer-effect" word-prop effect-out
dup [ word? ] all? [ drop f ] unless
] if* ;
M: #call infer-classes* ( node -- )
M: #call infer-classes*
dup create-ties dup output-classes
[ swap node-out-d intersect-classes ] [ drop ] if* ;
M: #push infer-classes* ( node -- )
M: #push infer-classes*
node-out-d
[ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-ties ( node -- seq )
M: #if child-ties
node-in-d first dup general-t <class-tie>
swap f <literal-tie> 2array ;
M: #dispatch child-ties ( node -- seq )
M: #dispatch child-ties
dup node-in-d first
swap node-children length [ <literal-tie> ] map-with ;
M: #declare infer-classes* ( node -- )
M: #declare infer-classes*
dup node-param swap node-in-d [ set-value-class* ] 2each ;
DEFER: (infer-classes)

14
library/compiler/optimizer/kill-literals.factor
View File

@ -34,16 +34,16 @@ GENERIC: live-values* ( node -- seq )
dup live-values over literals hash-diff swap kill-node ;
! Generic nodes
M: node literals* ( node -- ) drop { } ;
M: node literals* drop { } ;
M: node live-values* ( node -- seq )
M: node live-values*
node-in-d [ value? ] subset ;
! #push
M: #push literals* ( node -- seq ) node-out-d ;
M: #push literals* node-out-d ;
! #return
M: #return live-values* ( node -- seq )
M: #return live-values*
#! Values returned by local labels can be killed.
dup node-param [ drop { } ] [ delegate live-values* ] if ;
@ -51,7 +51,7 @@ M: #return live-values* ( node -- seq )
UNION: #killable
#push #shuffle #call-label #merge #values #entry ;
M: #killable live-values* ( node -- seq ) drop { } ;
M: #killable live-values* drop { } ;
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
@ -59,14 +59,14 @@ M: #killable live-values* ( node -- seq ) drop { } ;
unify-lengths flip [ all-eq? not ] subset concat ;
! #label
M: #label live-values* ( node -- seq )
M: #label live-values*
dup node-child node-in-d over node-in-d 2array
swap collect-recursion append purge-invariants ;
! branching
UNION: #branch #if #dispatch ;
M: #branch live-values* ( node -- )
M: #branch live-values*
#! This assumes that the last element of each branch is a
#! #return node.
dup delegate live-values* >r

12
library/compiler/optimizer/optimizer.factor
View File

@ -31,18 +31,18 @@ GENERIC: optimize-node* ( node -- node/t )
! Generic nodes
M: f optimize-node* drop t ;
M: node optimize-node* ( node -- t ) drop t ;
M: node optimize-node* drop t ;
! #shuffle
M: #shuffle optimize-node* ( node -- node/t )
M: #shuffle optimize-node*
[ node-values empty? ] prune-if ;
! #push
M: #push optimize-node* ( node -- node/t )
M: #push optimize-node*
[ node-out-d empty? ] prune-if ;
! #return
M: #return optimize-node* ( node -- node/t )
M: #return optimize-node*
node-successor [ node-successor ] [ t ] if* ;
! Some utilities for splicing in dataflow IR subtrees
@ -96,12 +96,12 @@ M: #return optimize-node* ( node -- node/t )
} cond
] if ;
M: #if optimize-node* ( node -- node/t )
M: #if optimize-node*
dup dup node-in-d first known-boolean-value?
[ 0 1 ? fold-branch ] [ 2drop t ] if ;
! #dispatch
M: #dispatch optimize-node* ( node -- node/t )
M: #dispatch optimize-node*
dup dup node-in-d first 2dup node-literal? [
node-literal fold-branch
] [

20
library/compiler/optimizer/print-dataflow.factor
View File

@ -9,7 +9,7 @@ GENERIC: node>quot ( node -- )
TUPLE: comment node text ;
M: comment pprint* ( ann -- )
M: comment pprint*
"( " over comment-text " )" append3
swap comment-node presented associate
styled-text ;
@ -36,10 +36,10 @@ M: comment pprint* ( ann -- )
" r: " swap node-out-r values%
] "" make 1 tail ;
M: #shuffle node>quot ( ? node -- )
M: #shuffle node>quot
>r drop t r> dup effect-str "#shuffle: " swap append comment, ;
M: #push node>quot ( ? node -- ) nip >#push< % ;
M: #push node>quot nip >#push< % ;
DEFER: dataflow>quot
@ -47,26 +47,26 @@ DEFER: dataflow>quot
dup node-param dup
[ , dup effect-str comment, ] [ 3drop ] if ;
M: #call node>quot ( ? node -- ) #call>quot ;
M: #call node>quot #call>quot ;
M: #call-label node>quot ( ? node -- ) #call>quot ;
M: #call-label node>quot #call>quot ;
M: #label node>quot ( ? node -- )
M: #label node>quot
[ "#label: " over node-param word-name append comment, ] 2keep
node-child swap dataflow>quot , \ call , ;
M: #if node>quot ( ? node -- )
M: #if node>quot
[ "#if" comment, ] 2keep
node-children [ swap dataflow>quot ] map-with % \ if , ;
M: #dispatch node>quot ( ? node -- )
M: #dispatch node>quot
[ "#dispatch" comment, ] 2keep
node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
M: #return node>quot ( ? node -- )
M: #return node>quot
dup node-param unparse "#return " swap append comment, ;
M: object node>quot ( ? node -- ) dup class word-name comment, ;
M: object node>quot dup class word-name comment, ;
: (dataflow>quot) ( ? node -- )
dup [

12
library/compiler/ppc/architecture.factor
View File

@ -30,10 +30,10 @@ GENERIC: loc>operand
M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
M: immediate load-literal ( literal vreg -- )
M: immediate load-literal
[ v>operand ] 2apply LOAD ;
M: object load-literal ( literal vreg -- )
M: object load-literal
v>operand
[ 0 swap LOAD32 rel-absolute-2/2 rel-literal ] keep
dup 0 LWZ ;
@ -91,14 +91,14 @@ M: object load-literal ( literal vreg -- )
: compile-dlsym ( symbol dll register -- )
0 swap LOAD32 rel-absolute-2/2 rel-dlsym ;
M: int-regs (%peek) ( vreg loc -- )
M: int-regs (%peek)
drop >r v>operand r> loc>operand LWZ ;
M: float-regs (%peek) ( vreg loc -- )
M: float-regs (%peek)
drop fp-scratch v>operand swap loc>operand LWZ
fp-scratch [ v>operand ] 2apply float-offset LFD ;
M: int-regs (%replace) ( vreg loc -- )
M: int-regs (%replace)
drop >r v>operand r> loc>operand STW ;
: %move-int>int ( dst src -- )
@ -124,7 +124,7 @@ M: int-regs (%replace) ( vreg loc -- )
r> call 12 12 \ size get call ADDI
] bind save-allot-ptr ; inline
M: float-regs (%replace) ( vreg loc reg-class -- )
M: float-regs (%replace)
drop swap
[ v>operand 12 8 STFD ]
[ 11 swap loc>operand STW ] H{

8
library/compiler/x86/architecture.factor
View File

@ -87,13 +87,13 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
: prepare-division CDQ ; inline
M: immediate load-literal ( literal vreg -- )
M: immediate load-literal
v>operand swap v>operand MOV ;
: load-indirect ( literal reg -- )
0 [] MOV rel-absolute-cell rel-literal ;
M: object load-literal ( literal vreg -- )
M: object load-literal
v>operand load-indirect ;
: (%call) ( label -- label )
@ -150,6 +150,6 @@ M: int-regs (%replace) drop swap %move-int>int ;
: %inc-r ( n -- ) cs-reg (%inc) ;
M: object %stack>freg ( n reg reg-class -- ) 3drop ;
M: object %stack>freg 3drop ;
M: object %freg>stack ( n reg reg-class -- ) 3drop ;
M: object %freg>stack 3drop ;

10
library/compiler/x86/assembler.factor
View File

@ -140,7 +140,7 @@ C: indirect ( base index scale displacement -- indirect )
GENERIC: sib-present?
M: indirect sib-present? ( indirect -- ? )
M: indirect sib-present?
dup indirect-base { ESP RSP } memq?
over indirect-index rot indirect-scale or or ;
@ -148,11 +148,11 @@ M: register sib-present? drop f ;
GENERIC: r/m
M: indirect r/m ( indirect -- r/m )
M: indirect r/m
dup sib-present?
[ drop ESP reg-code ] [ indirect-base* ] if ;
M: register r/m ( reg -- r/m ) reg-code ;
M: register r/m reg-code ;
: byte? -128 127 between? ;
@ -299,8 +299,8 @@ M: operand CALL BIN: 010 t HEX: ff 1-operand ;
G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
: (JUMPcc) HEX: 0f , , 0 4, rel-relative ;
M: callable JUMPcc ( addr opcode -- ) (JUMPcc) rel-word ;
M: label JUMPcc ( addr opcode -- ) (JUMPcc) rel-label ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) rel-label ;
: JO HEX: 80 JUMPcc ;
: JNO HEX: 81 JUMPcc ;

4
library/compiler/x86/intrinsics-sse2.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays assembler generic kernel kernel-internals
math math-internals memory namespaces sequences words ;
IN: compiler
M: float-regs (%peek) ( vreg loc reg-class -- )
M: float-regs (%peek)
drop
fp-scratch swap %move-int>int
fp-scratch %move-int>float ;
@ -32,7 +32,7 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
alloc-tmp-reg POP
] bind ; inline
M: float-regs (%replace) ( vreg loc reg-class -- )
M: float-regs (%replace)
drop
[ alloc-tmp-reg 8 [+] rot v>operand MOVSD ]
[ v>operand alloc-tmp-reg MOV ] H{

1
library/generic/classes.factor
View File

@ -123,7 +123,6 @@ SYMBOL: class<cache
: define-class ( class -- )
dup t "class" set-word-prop
dup H{ } clone "class<" set-word-prop
dup flatten-class typemap get set-hash ;
! Predicate classes for generalized predicate dispatch.

4
library/generic/math-combination.factor
View File

@ -41,8 +41,8 @@ math namespaces sequences words ;
TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- )
3dup <no-math-method> throw ;
: no-math-method ( left right generic -- * )
<no-math-method> throw ;
: applicable-method ( generic class -- quot )
over method [ ] [ [ no-math-method ] curry ] ?if ;

26
library/generic/slots.factor
View File

@ -9,21 +9,29 @@ parser sequences strings words ;
over define-generic -rot define-method ;
: define-slot-word ( class slot word quot -- )
over [
rot >fixnum add* define-typecheck
rot >fixnum add* define-typecheck ;
: reader-effect 1 1 <effect> ; inline
: define-reader ( class slot decl reader -- )
dup [
dup reader-effect "declared-effect" set-word-prop
[ slot ] rot dup object eq?
[ drop ] [ 1array [ declare ] swap add* append ] if
define-slot-word
] [
2drop 2drop
] if ;
: define-reader ( class slot decl reader -- )
[ slot ] rot dup object eq? [
drop
] [
1array [ declare ] swap add* append
] if define-slot-word ;
: writer-effect 2 0 <effect> ; inline
: define-writer ( class slot writer -- )
[ set-slot ] define-slot-word ;
dup [
dup writer-effect "declared-effect" set-word-prop
[ set-slot ] define-slot-word
] [
3drop
] if ;
: define-slot ( class slot decl reader writer -- )
>r >r >r 2dup r> r> define-reader r> define-writer ;

2
library/generic/standard-combination.factor
View File

@ -12,7 +12,7 @@ IN: generic
TUPLE: no-method object generic ;
: no-method ( object generic -- ) <no-method> throw ;
: no-method ( object generic -- * ) <no-method> throw ;
: error-method ( dispatch# word -- method )
>r picker r> [ no-method ] curry append ;

6
library/generic/tuple.factor
View File

@ -77,12 +77,12 @@ TUPLE: check-tuple class ;
dup r> tuple-slots
default-constructor ;
M: tuple clone ( tuple -- tuple )
M: tuple clone
(clone) dup delegate clone over set-delegate ;
M: tuple hashcode ( tuple -- n ) 2 slot hashcode ;
M: tuple hashcode 2 slot hashcode ;
M: tuple equal? ( obj tuple -- ? )
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
: (delegates) ( obj -- )

2
library/help/topics.factor
View File

@ -13,7 +13,7 @@ SYMBOL: articles
TUPLE: article title content loc ;
TUPLE: no-article name ;
: no-article ( name -- ) <no-article> throw ;
: no-article ( name -- * ) <no-article> throw ;
: article ( name -- article )
dup articles get hash [ ] [ no-article ] ?if ;

12
library/io/c-streams.factor
View File

@ -11,19 +11,19 @@ USING: errors kernel kernel-internals namespaces io strings ;
TUPLE: c-stream in out ;
M: c-stream stream-write1 ( char stream -- )
M: c-stream stream-write1
>r ch>string r> stream-write ;
M: c-stream stream-write ( str stream -- )
M: c-stream stream-write
c-stream-out fwrite ;
M: c-stream stream-read1 ( stream -- char/f )
M: c-stream stream-read1
c-stream-in dup [ fgetc ] when ;
M: c-stream stream-flush ( stream -- )
M: c-stream stream-flush
c-stream-out [ fflush ] when* ;
M: c-stream stream-close ( stream -- )
M: c-stream stream-close
dup c-stream-in [ fclose ] when*
c-stream-out [ fclose ] when* ;
@ -47,7 +47,7 @@ IN: io
TUPLE: client-stream host port ;
TUPLE: c-stream-error ;
: c-stream-error <c-stream-error> throw ;
: c-stream-error ( -- * ) <c-stream-error> throw ;
: <client> c-stream-error ;
: <server> c-stream-error ;

4
library/io/lines.factor
View File

@ -26,11 +26,11 @@ C: line-reader ( stream -- line ) [ set-delegate ] keep ;
2drop
] if ;
M: line-reader stream-readln ( line -- string )
M: line-reader stream-readln
[ f swap (readln) ] "" make
dup empty? [ f ? ] [ nip ] if ;
M: line-reader stream-read ( count line -- string )
M: line-reader stream-read
[ delegate stream-read ] keep dup cr> [
over empty? [
drop

2
library/io/nested-style.factor
View File

@ -31,7 +31,7 @@ M: nested-style-stream stream-write1
3array >quotation
r> r> do-nested-style ;
M: nested-style-stream with-stream-style ( quot style stream -- )
M: nested-style-stream with-stream-style
do-nested-style with-stream-style ;
M: nested-style-stream with-nested-stream

6
library/io/plain-stream.factor
View File

@ -10,11 +10,11 @@ C: plain-writer ( stream -- stream ) [ set-delegate ] keep ;
M: plain-writer stream-terpri CHAR: \n swap stream-write1 ;
M: plain-writer stream-format ( string style stream -- )
M: plain-writer stream-format
highlight rot hash [ >r >upper r> ] when stream-write ;
M: plain-writer with-nested-stream ( quot style stream -- )
M: plain-writer with-nested-stream
nip swap with-stream* ;
M: plain-writer with-stream-style ( quot style stream -- )
M: plain-writer with-stream-style
(with-stream-style) ;

6
library/io/string-streams.factor
View File

@ -26,7 +26,7 @@ M: sbuf stream-flush drop ;
swap dup length <reversed>
[ zero? rot [ call ] keep swap ] 2map nip ; inline
M: plain-writer with-stream-table ( grid quot style stream -- )
M: plain-writer with-stream-table
[
drop swap
[ [ swap string-out ] map-with ] map-with
@ -36,10 +36,10 @@ M: plain-writer with-stream-table ( grid quot style stream -- )
] with-stream* ;
! Reversed string buffers support the stream input protocol.
M: sbuf stream-read1 ( sbuf -- char/f )
M: sbuf stream-read1
dup empty? [ drop f ] [ pop ] if ;
M: sbuf stream-read ( count sbuf -- string )
M: sbuf stream-read
dup empty? [
2drop f
] [

20
library/io/unix/io.factor
View File

@ -35,7 +35,7 @@ SYMBOL: write-tasks
! Some general stuff
: file-mode OCT: 0600 ;
: (io-error) err_no strerror throw ;
: (io-error) ( -- * ) err_no strerror throw ;
: check-null ( n -- ) zero? [ (io-error) ] when ;
@ -69,7 +69,7 @@ C: port ( handle buffer -- port )
dup port-timeout dup zero?
[ 2drop ] [ millis + swap set-port-cutoff ] if ;
M: port set-timeout ( timeout port -- )
M: port set-timeout
[ set-port-timeout ] keep touch-port ;
: buffered-port 32768 <buffer> <port> ;
@ -183,7 +183,7 @@ TUPLE: read1-task ;
C: read1-task ( port -- task )
[ >r <io-task> r> set-delegate ] keep ;
M: read1-task do-io-task ( task -- ? )
M: read1-task do-io-task
io-task-port dup refill [
[
dup buffer-empty?
@ -198,7 +198,7 @@ M: read1-task task-container drop read-tasks get-global ;
[ swap <read1-task> add-io-task stop ] callcc0
] when pending-error ;
M: input-port stream-read1 ( stream -- char/f )
M: input-port stream-read1
dup wait-to-read1
dup port-eof? [ drop f ] [ buffer-pop ] if ;
@ -222,7 +222,7 @@ C: read-task ( count port -- task )
: >read-task< dup read-task-count swap io-task-port ;
M: read-task do-io-task ( task -- ? )
M: read-task do-io-task
>read-task< dup refill [
dup buffer-empty? [
reader-eof drop t
@ -240,7 +240,7 @@ M: read-task task-container drop read-tasks get-global ;
[ -rot <read-task> add-io-task stop ] callcc0
] unless pending-error drop ;
M: input-port stream-read ( count stream -- string )
M: input-port stream-read
[ wait-to-read ] keep dup port-eof?
[ drop f ] [ port-sbuf >string ] if ;
@ -287,19 +287,19 @@ M: write-task task-container drop write-tasks get-global ;
: port-flush ( port -- )
[ swap <write-task> add-write-io-task stop ] callcc0 drop ;
M: output-port stream-flush ( stream -- )
M: output-port stream-flush
dup port-flush pending-error ;
: wait-to-write ( len port -- )
tuck can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1 ( char writer -- )
M: output-port stream-write1
1 over wait-to-write ch>buffer ;
M: output-port stream-write ( string writer -- )
M: output-port stream-write
over length over wait-to-write >buffer ;
M: port stream-close ( stream -- )
M: port stream-close
dup port-type closed eq? [
dup port-type >r closed over set-port-type r>
output eq? [ dup port-flush ] when dup port-handle close

4
library/io/unix/sockets.factor
View File

@ -47,7 +47,7 @@ TUPLE: connect-task ;
C: connect-task ( port -- task )
[ >r <io-task> r> set-delegate ] keep ;
M: connect-task do-io-task ( task -- )
M: connect-task do-io-task
io-task-port dup port-handle 0 0 write
0 < [ defer-error ] [ drop t ] if ;
@ -104,7 +104,7 @@ C: accept-task ( port -- task )
swap sockaddr-in-port ntohs
] keep <client-stream> swap set-server-client ;
M: accept-task do-io-task ( task -- ? )
M: accept-task do-io-task
io-task-port "sockaddr-in" <c-object>
over port-handle over "sockaddr-in" c-size <int> accept
dup 0 >= [

2
library/io/windows/errors.factor
View File

@ -24,6 +24,6 @@ USING: alien errors io-internals kernel math parser sequences words ;
FUNCTION: char* error_message ( DWORD id ) ;
: win32-throw-error ( -- )
: win32-throw-error ( -- * )
GetLastError error_message throw ;

6
library/io/windows/server.factor
View File

@ -65,13 +65,13 @@ C: win32-server ( port -- server )
dup stream set
] make-hash over set-win32-server-this ;
M: win32-server stream-close ( server -- )
M: win32-server stream-close
win32-server-this [ socket get CloseHandle drop ] bind ;
M: win32-server set-timeout ( timeout server -- )
M: win32-server set-timeout
win32-server-this [ timeout set ] bind ;
M: win32-server expire ( -- )
M: win32-server expire
win32-server-this [
timeout get [ millis cutoff get > [ socket get CancelIo ] when ] when
] bind ;

28
library/io/windows/stream.factor
View File

@ -49,11 +49,11 @@ SYMBOL: cutoff
: maybe-flush-output ( -- )
out-buffer get buffer-length 0 > [ flush-output ] when ;
M: integer do-write ( int -- )
M: integer do-write
out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
>r ch>string r> >buffer ;
M: string do-write ( str -- )
M: string do-write
dup length out-buffer get buffer-capacity <= [
out-buffer get >buffer
] [
@ -97,30 +97,30 @@ M: string do-write ( str -- )
: peek-input ( -- str )
1 in-buffer get buffer-first-n ;
M: win32-stream stream-write ( str stream -- )
M: win32-stream stream-write
win32-stream-this [ do-write ] bind ;
M: win32-stream stream-write1 ( char stream -- )
M: win32-stream stream-write1
win32-stream-this [ >fixnum do-write ] bind ;
M: win32-stream stream-read ( count stream -- str )
M: win32-stream stream-read
win32-stream-this [ dup <sbuf> swap do-read-count ] bind ;
M: win32-stream stream-read1 ( stream -- str )
M: win32-stream stream-read1
win32-stream-this [
1 consume-input dup length zero? [ drop f ] when first
] bind ;
M: win32-stream stream-readln ( stream -- str )
M: win32-stream stream-readln
win32-stream-this [ readln ] bind ;
M: win32-stream stream-terpri
win32-stream-this [ CHAR: \n do-write ] bind ;
M: win32-stream stream-flush ( stream -- )
M: win32-stream stream-flush
win32-stream-this [ maybe-flush-output ] bind ;
M: win32-stream stream-close ( stream -- )
M: win32-stream stream-close
win32-stream-this [
maybe-flush-output
handle get CloseHandle drop
@ -128,21 +128,21 @@ M: win32-stream stream-close ( stream -- )
out-buffer get buffer-free
] bind ;
M: win32-stream stream-format ( string style stream -- )
M: win32-stream stream-format
win32-stream-this [ drop do-write ] bind ;
M: win32-stream win32-stream-handle ( stream -- handle )
M: win32-stream win32-stream-handle
win32-stream-this [ handle get ] bind ;
M: win32-stream set-timeout ( timeout stream -- )
M: win32-stream set-timeout
win32-stream-this [ timeout set ] bind ;
M: win32-stream expire ( stream -- )
M: win32-stream expire
win32-stream-this [
timeout get [ millis cutoff get > [ handle get CancelIo ] when ] when
] bind ;
M: win32-stream with-nested-stream ( quot style stream -- )
M: win32-stream with-nested-stream
win32-stream-this [ drop stream get swap with-stream* ] bind ;
C: win32-stream ( handle -- stream )

14
library/math/complex.factor
View File

@ -13,7 +13,7 @@ UNION: number real complex ;
M: real real ;
M: real imaginary drop 0 ;
M: number equal? ( n n -- ? ) number= ;
M: number equal? number= ;
: rect> ( xr xi -- x )
over real? over real? and [
@ -42,7 +42,7 @@ IN: math-internals
: 2>rect ( x y -- xr yr xi yi )
[ [ real ] 2apply ] 2keep [ imaginary ] 2apply ; inline
M: complex number= ( x y -- ? )
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
@ -50,16 +50,16 @@ M: complex number= ( x y -- ? )
M: complex + 2>rect + >r + r> (rect>) ;
M: complex - 2>rect - >r - r> (rect>) ;
M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ;
M: complex * 2dup *re - -rot *im + (rect>) ;
: complex/ ( x y -- r i m )
#! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
dup absq >r 2dup *re + -rot *im - r> ; inline
M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ;
M: complex / complex/ tuck / >r / r> (rect>) ;
M: complex /f complex/ tuck /f >r /f r> (rect>) ;
M: complex abs ( z -- |z| ) absq fsqrt ;
M: complex abs absq fsqrt ;
M: complex hashcode ( n -- n )
M: complex hashcode
>rect >fixnum swap >fixnum bitxor ;

4
library/math/float.factor
View File

@ -14,13 +14,13 @@ UNION: real rational float ;
M: real abs dup 0 < [ neg ] when ;
M: real absq sq ;
M: real hashcode ( n -- n ) >fixnum ;
M: real hashcode >fixnum ;
M: real <=> - ;
: fp-nan? ( float -- ? )
double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
M: float zero? ( float -- ? )
M: float zero?
dup 0.0 float= swap -0.0 float= or ;
M: float < float< ;

4
library/math/integer.factor
View File

@ -42,9 +42,9 @@ IN: math-internals
dup 1 number= [ drop ] [ (fraction>) ] if ; inline
TUPLE: /0 ;
: /0 ( -- ) </0> throw ;
: /0 ( -- * ) </0> throw ;
M: integer / ( x y -- x/y )
M: integer /
dup zero? [
/0
] [

8
library/math/parse-numbers.factor
View File

@ -6,7 +6,7 @@ strings ;
DEFER: base>
: string>ratio ( "a/b" radix -- a/b )
: string>ratio ( str radix -- a/b )
>r "/" split1 r> tuck base> >r base> r>
2dup and [ / ] [ 2drop f ] if ;
@ -51,7 +51,7 @@ M: object digit> drop f ;
G: >base ( num radix -- string ) 1 standard-combination ;
M: integer >base ( num radix -- string )
M: integer >base
[
over 0 < [
swap neg swap integer, CHAR: - ,
@ -60,7 +60,7 @@ M: integer >base ( num radix -- string )
] if
] "" make reverse ;
M: ratio >base ( num radix -- string )
M: ratio >base
[
over numerator over >base %
CHAR: / ,
@ -70,7 +70,7 @@ M: ratio >base ( num radix -- string )
: fix-float
CHAR: . over member? [ ".0" append ] unless ;
M: float >base ( num radix -- string )
M: float >base
drop {
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }

4
library/math/pow.factor
View File

@ -27,7 +27,7 @@ GENERIC: (^) ( z w -- z^w ) foldable
: ^theta ( w abs arg -- theta )
>r >r >rect r> flog * swap r> * + ; inline
M: number (^) ( z w -- z^w )
M: number (^)
swap >polar 3dup ^theta >r ^mag r> polar> ;
: ^n ( z w -- z^w )
@ -37,7 +37,7 @@ M: number (^) ( z w -- z^w )
{ [ t ] [ over sq over 2 /i ^n -rot 2 mod ^n * ] }
} cond ; inline
M: integer (^) ( z w -- z^w )
M: integer (^)
dup 0 < [ neg ^n recip ] [ ^n ] if ;
: power-of-2? ( n -- ? )

8
library/math/ratio.factor
View File

@ -16,7 +16,7 @@ IN: math-internals
: 2>fraction ( a/b c/d -- a c b d )
[ >fraction ] 2apply swapd ; inline
M: ratio number= ( a/b c/d -- ? )
M: ratio number=
2>fraction number= [ number= ] [ 2drop f ] if ;
: scale ( a/b c/d -- a*d b*c )
@ -30,9 +30,9 @@ M: ratio <= scale <= ;
M: ratio > scale > ;
M: ratio >= scale >= ;
M: ratio + ( x y -- x+y ) 2dup scale + -rot ratio+d / ;
M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d / ;
M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ;
M: ratio + 2dup scale + -rot ratio+d / ;
M: ratio - 2dup scale - -rot ratio+d / ;
M: ratio * 2>fraction * >r * r> / ;
M: ratio / scale / ;
M: ratio /i scale /i ;
M: ratio mod 2dup >r >r /i r> r> rot * - ;

2
library/quotations.factor
View File

@ -22,7 +22,7 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
: make-dip ( quot n -- quot )
dup \ >r <array> -rot \ r> <array> append3 >quotation ;
: unit ( a -- [ a ] ) 1array >quotation ;
: unit ( a -- quot ) 1array >quotation ;
GENERIC: literalize ( obj -- obj )
M: object literalize ;

19
library/syntax/early-parser.factor
View File

@ -50,3 +50,22 @@ C: parse-error ( error -- error )
column get over set-parse-error-col
line-text get over set-parse-error-text
[ set-delegate ] keep ;
TUPLE: effect in out declarations terminated? ;
C: effect
[
over { "*" } sequence=
[ nip t swap set-effect-terminated? ]
[ set-effect-out ] if
] keep
[ set-effect-in ] keep
H{ } clone over set-effect-declarations ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;
: effect<= ( eff1 eff2 -- ? )
2dup [ effect-terminated? ] 2apply = >r
2dup [ effect-in length ] 2apply <= >r
[ effect-height ] 2apply number= r> and r> and ;

18
library/syntax/parse-syntax.factor
View File

@ -11,12 +11,6 @@ USING: alien arrays compiler definitions errors generic
hashtables kernel math modules namespaces parser sequences
strings vectors words ;
: !(
CHAR: ) column [
line-text get index* dup -1 =
[ "Unterminated (" throw ] when 1+
] change ; parsing
: !! line-text get length column set ; parsing
: !#! POSTPONE: ! ; parsing
: !IN: scan set-in ; parsing
@ -83,3 +77,15 @@ DEFER: !PRIMITIVE: parsing
: !REQUIRES:
string-mode on
[ string-mode off [ (require) ] each ] f ; parsing
: !(
word parse-effect dup 1array >vector effect-stack set
"declared-effect" set-word-prop ; parsing
: !|
scan scan-word \ ( eq? [
parse-effect dup effect-stack get push
swap add-declaration
] [
"Expected (" throw
] if ; parsing

20
library/syntax/parser.factor
View File

@ -57,7 +57,7 @@ TUPLE: no-word name ;
: (parse) ( str -- ) line-text set 0 column set parse-loop ;
TUPLE: bad-escape ;
: bad-escape ( -- ) <bad-escape> throw ;
: bad-escape ( -- * ) <bad-escape> throw ;
! Parsing word utilities
: escape ( ch -- esc )
@ -90,6 +90,24 @@ TUPLE: bad-escape ;
column
[ [ line-text get (parse-string) ] "" make swap ] change ;
SYMBOL: effect-stack
: (parse-effect)
scan [
dup ")" = [ drop ] [ , (parse-effect) ] if
] [
"Unexpected EOL" throw
] if* ;
: parse-effect ( -- effect )
[ (parse-effect) column get ] { } make swap column set
{ "--" } split1 <effect> ;
: add-declaration ( effect name -- )
effect-stack get [
2dup effect-in member? >r dupd effect-out member? r> or
] find nip effect-declarations set-hash ;
global [
{
"scratchpad" "syntax" "arrays" "compiler" "definitions"

32
library/syntax/prettyprint.factor
View File

@ -122,7 +122,7 @@ TUPLE: newline ;
C: newline ( -- section )
H{ } 0 <section> over set-delegate ;
M: newline pprint-section* ( newline -- )
M: newline pprint-section*
section-start fresh-line ;
: newline ( -- ) <newline> add-section ;
@ -138,7 +138,7 @@ M: newline pprint-section* ( newline -- )
: style> stdio [ delegate ] change ;
M: block pprint-section* ( block -- )
M: block pprint-section*
dup <style
f swap block-sections [
over [ dup advance ] when pprint-section drop t
@ -175,11 +175,11 @@ GENERIC: pprint* ( obj -- )
: pprint-word ( obj -- )
dup word-name swap word-style styled-text ;
M: object pprint* ( obj -- )
M: object pprint*
"( unprintable object: " swap class word-name " )" append3
text ;
M: real pprint* ( obj -- ) number>string text ;
M: real pprint* number>string text ;
: ch>ascii-escape ( ch -- esc )
H{
@ -213,18 +213,18 @@ M: real pprint* ( obj -- ) number>string text ;
[ % [ unparse-ch ] each CHAR: " , ] "" make
do-string-limit text ;
M: string pprint* ( str -- str ) "\"" pprint-string ;
M: string pprint* "\"" pprint-string ;
M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
M: sbuf pprint* "SBUF\" " pprint-string ;
M: word pprint* ( word -- )
M: word pprint*
dup "pprint-close" word-prop [ block> ] when
dup pprint-word
"pprint-open" word-prop [ H{ } <block ] when ;
M: f pprint* drop \ f pprint-word ;
M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
M: dll pprint* dll-path "DLL\" " pprint-string ;
: nesting-limit? ( -- ? )
nesting-limit get dup [ pprinter-stack get length < ] when ;
@ -273,22 +273,22 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
: pprint-sequence ( seq start end -- )
swap pprint* swap pprint-elements pprint* ;
M: complex pprint* ( num -- )
M: complex pprint*
>rect 2array \ C{ \ } pprint-sequence ;
M: quotation pprint* ( list -- )
M: quotation pprint*
[ \ [ \ ] pprint-sequence ] check-recursion ;
M: array pprint* ( vector -- )
M: array pprint*
[ \ { \ } pprint-sequence ] check-recursion ;
M: vector pprint* ( vector -- )
M: vector pprint*
[ \ V{ \ } pprint-sequence ] check-recursion ;
M: hashtable pprint* ( hashtable -- )
M: hashtable pprint*
[ hash>alist \ H{ \ } pprint-sequence ] check-recursion ;
M: tuple pprint* ( tuple -- )
M: tuple pprint*
[
\ T{ pprint*
tuple>array dup first pprint*
@ -296,14 +296,14 @@ M: tuple pprint* ( tuple -- )
\ } pprint*
] check-recursion ;
M: alien pprint* ( alien -- )
M: alien pprint*
dup expired? [
drop "( alien expired )"
] [
\ ALIEN: pprint-word alien-address number>string
] if text ;
M: wrapper pprint* ( wrapper -- )
M: wrapper pprint*
dup wrapped word? [
\ \ pprint-word wrapped pprint-word
] [

84
library/test/inference.factor
View File

@ -1,7 +1,7 @@
IN: temporary
USING: arrays errors generic inference kernel kernel-internals
math math-internals namespaces parser sequences strings test
vectors ;
vectors words ;
IN: temporary
[ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
@ -66,22 +66,22 @@ vectors ;
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
[ [ no-base-case-1 ] infer ] unit-test-fails
: simple-recursion-1
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
[ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test
: simple-recursion-2
: simple-recursion-2 ( obj -- obj )
dup [ ] [ simple-recursion-2 ] if ;
[ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test
: bad-recursion-2
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ [ bad-recursion-2 ] infer ] unit-test-fails
: funny-recursion
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
[ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test
@ -122,7 +122,7 @@ DEFER: foe
[ { 0 0 } ] [ [ nested-when ] infer ] unit-test
: nested-when* ( -- )
: nested-when* ( obj -- )
[
[
drop
@ -144,7 +144,7 @@ SYMBOL: sym-test
[ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test
: recursive-terminator
: recursive-terminator ( obj -- )
dup [
recursive-terminator
] [
@ -153,49 +153,48 @@ SYMBOL: sym-test
[ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test
GENERIC: potential-hang
GENERIC: potential-hang ( obj -- obj )
M: fixnum potential-hang dup [ potential-hang ] when ;
[ ] [ [ 5 potential-hang ] infer drop ] unit-test
TUPLE: funny-cons car cdr ;
GENERIC: iterate
GENERIC: iterate ( obj -- )
M: funny-cons iterate funny-cons-cdr iterate ;
M: f iterate drop ;
M: real iterate drop ;
[ { 1 0 } ] [ [ iterate ] infer ] unit-test
DEFER: agent
DEFER: agent ( a b -- c d )
: smith 1+ agent ; inline
: agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline
[ { 0 2 } ]
[ [ [ drop ] 0 agent ] infer ] unit-test
: no-base-case-2 no-base-case-2 ;
[ [ no-base-case-2 ] infer ] unit-test-fails
! Regression
: cat dup [ throw ] [ throw ] if ;
: dog dup [ cat ] [ 3drop ] if ;
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
[ { 3 0 } ] [ [ dog ] infer ] unit-test
! Regression
DEFER: monkey
: friend dup [ friend ] [ monkey ] if ;
: monkey dup [ 3drop ] [ friend ] if ;
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
[ { 3 0 } ] [ [ friend ] infer ] unit-test
! Regression -- same as above but we infer the second word first
DEFER: blah2
: blah dup [ blah ] [ blah2 ] if ;
: blah2 dup [ blah ] [ 3drop ] if ;
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
[ { 3 0 } ] [ [ blah2 ] infer ] unit-test
! Regression
DEFER: blah4
: blah3 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
: blah3 ( a b c -- )
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 ( a b c -- )
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
[ { 3 0 } ] [ [ blah4 ] infer ] unit-test
! Regression
@ -206,7 +205,7 @@ DEFER: blah4
[ swap slip ] keep swap bad-combinator
] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
! [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
! Regression
: bad-input#
@ -219,18 +218,19 @@ DEFER: blah4
! This order of branches works
DEFER: do-crap
: more-crap dup [ drop ] [ dup do-crap call ] if ;
: do-crap dup [ more-crap ] [ do-crap ] if ;
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
[ [ do-crap ] infer ] unit-test-fails
! This one does not
DEFER: do-crap*
: more-crap* dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* dup [ do-crap* ] [ more-crap* ] if ;
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
[ [ do-crap* ] infer ] unit-test-fails
! Regression
: too-deep dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
[ { 2 1 } ] [ [ too-deep ] infer ] unit-test
! Error reporting is wrong
@ -247,7 +247,7 @@ DEFER: A
DEFER: B
DEFER: C
: A
: A ( a -- )
dup {
[ drop ]
[ A ]
@ -255,7 +255,7 @@ DEFER: C
[ dup C A ]
} dispatch ;
: B
: B ( b -- )
dup {
[ C ]
[ B ]
@ -263,7 +263,7 @@ DEFER: C
[ dup B B ]
} dispatch ;
: C
: C ( c -- )
dup {
[ A ]
[ C ]
@ -277,16 +277,26 @@ DEFER: C
! I found this bug by thinking hard about the previous one
DEFER: Y
: X dup [ swap Y ] [ ] if ;
: Y X ;
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
: Y ( a b -- c d ) X ;
[ { 2 2 } ] [ [ X ] infer ] unit-test
[ { 2 2 } ] [ [ Y ] infer ] unit-test
! This one comes from UI code
DEFER: #1
: #2 ( a b -- ) dup [ call ] [ 2drop ] if ; inline
: #3 ( a -- ) [ #1 ] #2 ;
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer ] unit-test-fails
[ [ #1 ] infer ] unit-test-fails
! Similar
DEFER: bar
: foo dup [ 2drop f f bar ] [ ] if ;
: bar [ 2 2 + ] t foo drop call drop ;
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
[ [ foo ] infer ] unit-test-fails
@ -297,12 +307,12 @@ DEFER: bar
! This form should not have a stack effect
: bad-recursion-1
: bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ;
[ [ bad-recursion-1 ] infer ] unit-test-fails
: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] unit-test-fails
! Test some random library words

41
library/test/parser.factor
View File

@ -1,9 +1,5 @@
USING: arrays errors math parser test kernel generic words ;
IN: temporary
USE: parser
USE: test
USE: kernel
USE: generic
USE: words
[ 1 CHAR: a ]
[ 0 "abcd" next-char ] unit-test
@ -43,10 +39,6 @@ unit-test
[ "! This is a comment, people." parse call ]
unit-test
[ ]
[ "( This is a comment, people. )" parse call ]
unit-test
! Test escapes
[ [ " " ] ]
@ -63,3 +55,34 @@ unit-test
[ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test
[ word ] [ \ f class ] unit-test
! Test stack effect parsing
: foo ( a b -- c ) + ;
[ T{ effect f { "a" "b" } { "c" } H{ } f } ]
[ \ foo "declared-effect" word-prop ] unit-test
: bar ( a quot -- b ) | quot ( u -- v ) call ;
[
T{ effect f
{ "a" "quot" }
{ "b" }
H{ { "quot" T{ effect f { "u" } { "v" } H{ } } } }
f
}
]
[ \ bar "declared-effect" word-prop ] unit-test
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
: baz ( a b -- * ) 2array throw ;
[ t ]
[ \ baz "declared-effect" word-prop effect-terminated? ]
unit-test

2
library/test/test.factor
View File

@ -6,7 +6,7 @@ memory namespaces parser prettyprint sequences strings words
vectors ;
TUPLE: assert got expect ;
: assert ( got expect -- ) <assert> throw ;
: assert ( got expect -- * ) <assert> throw ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;

10
library/tools/debugger.factor
View File

@ -11,13 +11,13 @@ PREDICATE: array kernel-error ( obj -- ? )
GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
M: object error. ( error -- ) . ;
M: object error-help ( error -- topic ) drop f ;
M: object error. . ;
M: object error-help drop f ;
M: tuple error. ( error -- ) describe ;
M: tuple error-help ( error -- topic ) class ;
M: tuple error. describe ;
M: tuple error-help class ;
M: string error. ( error -- ) print ;
M: string error. print ;
SYMBOL: restarts

4
library/tools/describe.factor
View File

@ -12,9 +12,9 @@ GENERIC: sheet ( obj -- sheet )
dup third -rot first slot 2array
] map-with ;
M: object sheet ( obj -- sheet ) slot-sheet ;
M: object sheet slot-sheet ;
M: tuple sheet ( tuple -- sheet )
M: tuple sheet
dup slot-sheet swap delegate [ 1 tail ] unless ;
M: sequence summary

14
library/tools/errors.factor
View File

@ -80,14 +80,14 @@ DEFER: objc-error. ( alien -- )
callstack-overflow.
} nth ;
M: kernel-error error. ( error -- ) dup kernel-error execute ;
M: kernel-error error. dup kernel-error execute ;
M: kernel-error error-help ( error -- topic ) kernel-error ;
M: kernel-error error-help kernel-error ;
M: no-method summary
drop "No suitable method" ;
M: no-method error. ( error -- )
M: no-method error.
"Generic word " write
dup no-method-generic pprint
" does not define a method for the " write
@ -150,7 +150,7 @@ M: no-word summary
parse-error-col [ 0 ] unless*
CHAR: \s <string> write "^" print ;
M: parse-error error. ( error -- )
M: parse-error error.
dup parse-dump delegate error. ;
M: bounds-error summary drop "Sequence index out of bounds" ;
@ -159,15 +159,15 @@ M: condition error. delegate error. ;
M: condition error-help drop f ;
M: alien-callback-error summary ( error -- )
M: alien-callback-error summary
drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
M: alien-invoke-error summary ( error -- )
M: alien-invoke-error summary
drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
M: assert summary drop "Assertion failed" ;
M: inference-error error. ( error -- )
M: inference-error error.
"Inference error:" print
dup inference-error-message print
"Recursive state:" print

10
library/tools/interpreter.factor
View File

@ -120,23 +120,23 @@ SYMBOL: callframe-end
GENERIC: do-1 ( object -- )
M: word do-1 ( word -- )
M: word do-1
dup "meta-word" word-prop [ call ] [ host-word ] ?if ;
M: wrapper do-1 ( wrapper -- ) wrapped push-d ;
M: wrapper do-1 wrapped push-d ;
M: object do-1 ( object -- ) push-d ;
M: object do-1 push-d ;
GENERIC: do ( obj -- )
M: word do ( word -- )
M: word do
dup "meta-word" word-prop [
call
] [
dup compound? [ word-def meta-call ] [ host-word ] if
] ?if ;
M: object do ( object -- ) do-1 ;
M: object do do-1 ;
! The interpreter loses object identity of the name and catch
! stacks -- they are copied after each step -- so we execute

6
library/tools/summary.factor
View File

@ -9,7 +9,7 @@ GENERIC: summary ( object -- string )
M: object summary
"an instance of the " swap class word-name " class" append3 ;
M: word summary ( word -- )
M: word summary
dup word-vocabulary [
dup interned?
"a word in the " "a word orphaned from the " ?
@ -18,11 +18,11 @@ M: word summary ( word -- )
drop "a uniquely generated symbol"
] if ;
M: input summary ( input -- )
M: input summary
"Input: " swap input-string
dup string? [ unparse-short ] unless append ;
M: vocab-link summary ( vocab-link -- )
M: vocab-link summary
[
vocab-link-name dup %
" vocabulary (" %

4
library/ui/cocoa/pasteboard-utils.factor
View File

@ -23,10 +23,10 @@ sequences ;
TUPLE: pasteboard handle ;
M: pasteboard clipboard-contents ( pb -- str )
M: pasteboard clipboard-contents
pasteboard-handle pasteboard-string ;
M: pasteboard set-clipboard-contents ( str pb -- )
M: pasteboard set-clipboard-contents
pasteboard-handle set-pasteboard-string ;
: init-clipboard ( -- )

3
library/ui/gadgets.factor
View File

@ -67,8 +67,7 @@ M: gadget user-input* 2drop t ;
GENERIC: children-on ( rect/point gadget -- list )
M: gadget children-on ( rect/point gadget -- list )
nip gadget-children ;
M: gadget children-on nip gadget-children ;
: inside? ( bounds gadget -- ? )
dup gadget-visible?

4
library/ui/gadgets/books.factor
View File

@ -20,9 +20,9 @@ C: book ( pages -- book )
: <book-control> ( model pages -- book )
<book> [ show-page ] <control> ;
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
M: book pref-dim* book-page pref-dim ;
M: book layout* ( book -- )
M: book layout*
dup rect-dim swap book-page set-layout-dim ;
: make-book ( model obj quots -- assoc )

4
library/ui/gadgets/borders.factor
View File

@ -20,11 +20,11 @@ C: border ( child gap -- border )
dup rect-dim over border-size 2 v*n v-
swap gadget-child set-layout-dim ;
M: border pref-dim* ( border -- dim )
M: border pref-dim*
[ border-size 2 v*n ] keep
gadget-child pref-dim v+ ;
M: border layout* ( border -- )
M: border layout*
dup layout-border-loc layout-border-dim ;
: <spacing> ( -- gadget )

6
library/ui/gadgets/buttons.factor
View File

@ -70,7 +70,7 @@ C: repeat-button ( gadget quot -- button )
#! the mouse is held down.
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
M: repeat-button tick ( ms object -- ) nip button-clicked ;
M: repeat-button tick nip button-clicked ;
TUPLE: button-paint plain rollover pressed selected ;
@ -82,10 +82,10 @@ TUPLE: button-paint plain rollover pressed selected ;
{ [ t ] [ button-paint-plain ] }
} cond ;
M: button-paint draw-interior ( button paint -- )
M: button-paint draw-interior
button-paint draw-interior ;
M: button-paint draw-boundary ( button paint -- )
M: button-paint draw-boundary
button-paint draw-boundary ;
: <radio-control> ( model value gadget -- gadget )

2
library/ui/gadgets/controls.factor
View File

@ -18,7 +18,7 @@ M: control graft*
M: control ungraft*
dup control-self swap control-model remove-connection ;
M: control model-changed ( gadget -- )
M: control model-changed
[ control-model model-value ] keep
[ dup control-self swap control-quot call ] keep
control-self relayout ;

2
library/ui/gadgets/frames.factor
View File

@ -32,7 +32,7 @@ C: frame ( -- frame )
: fill-center ( horiz vert dim -- )
tuck (fill-center) (fill-center) ;
M: frame layout* ( frame -- dim )
M: frame layout*
dup [
[ rot rect-dim fill-center ] 2keep grid-layout
] with-grid ;

2
library/ui/gadgets/grid-lines.factor
View File

@ -20,7 +20,7 @@ SYMBOL: grid-dim
swap grid-positions grid get rect-dim { 1 0 } v- add
[ grid-line-from/to gl-line ] each-with ;
M: grid-lines draw-boundary ( gadget paint -- )
M: grid-lines draw-boundary
#! Clean this up later.
GL_MODELVIEW [
grid-lines-color gl-color [

4
library/ui/gadgets/grids.factor
View File

@ -39,7 +39,7 @@ C: grid ( children -- grid )
: (pair-up) ( horiz vert -- dim )
>r first r> second 2array ;
M: grid pref-dim* ( grid -- dim )
M: grid pref-dim*
[
[ gap [ v+ gap v+ ] reduce ] 2apply (pair-up)
] with-grid ;
@ -65,7 +65,7 @@ M: grid pref-dim* ( grid -- dim )
: grid-layout ( horiz vert -- )
2dup position-grid resize-grid ;
M: grid layout* ( frame -- dim )
M: grid layout*
[ grid-layout ] with-grid ;
: build-grid ( grid specs -- )

2
library/ui/gadgets/incremental.factor
View File

@ -19,7 +19,7 @@ C: incremental ( pack -- incremental )
[ set-gadget-delegate ] keep
dup delegate pref-dim over set-incremental-cursor ;
M: incremental pref-dim* ( incremental -- dim )
M: incremental pref-dim*
dup gadget-state [
dup delegate pref-dim over set-incremental-cursor
] when incremental-cursor ;

4
library/ui/gadgets/labels.factor
View File

@ -17,13 +17,13 @@ C: label ( text -- label )
dup label-font lookup-font dup font-height >r
swap label-text string-width r> 2array ;
M: label pref-dim* ( label -- dim ) label-size ;
M: label pref-dim* label-size ;
: draw-label ( label -- )
dup label-color gl-color
dup label-font swap label-text draw-string ;
M: label draw-gadget* ( label -- ) draw-label ;
M: label draw-gadget* draw-label ;
: <label-control> ( model -- gadget )
"" <label> [ set-label-text ] <control> ;

2
library/ui/gadgets/outliner.factor
View File

@ -8,7 +8,7 @@ gadgets-theme generic io kernel math opengl sequences styles ;
! Vertical line.
TUPLE: guide color ;
M: guide draw-interior ( gadget interior -- )
M: guide draw-interior
guide-color gl-color
rect-dim dup { 0.5 0 0 } v* swap { 0.5 1 0 } v* gl-line ;

18
library/ui/gadgets/panes.factor
View File

@ -43,11 +43,11 @@ C: pane ( -- pane )
GENERIC: write-gadget ( gadget stream -- )
M: pane write-gadget ( gadget pane -- )
M: pane write-gadget
#! Print a gadget to the given pane.
pane-current add-gadget ;
M: duplex-stream write-gadget ( gadget stream -- )
M: duplex-stream write-gadget
duplex-stream-out write-gadget ;
: print-gadget ( gadget pane -- )
@ -58,29 +58,29 @@ M: duplex-stream write-gadget ( gadget stream -- )
stdio get print-gadget ;
! Panes are streams.
M: pane stream-flush ( pane -- ) drop ;
M: pane stream-flush drop ;
: scroll-pane ( pane -- )
dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
M: pane stream-terpri ( pane -- )
M: pane stream-terpri
dup pane-current prepare-print
over pane-output add-incremental
dup prepare-line
scroll-pane ;
M: pane stream-write1 ( char pane -- )
M: pane stream-write1
[ pane-current stream-write1 ] keep scroll-pane ;
M: pane stream-write ( string pane -- )
M: pane stream-write
[ swap "\n" split pane-write ] keep scroll-pane ;
M: pane stream-format ( string style pane -- )
M: pane stream-format
[ rot "\n" split pane-format ] keep scroll-pane ;
M: pane stream-close ( pane -- ) drop ;
M: pane stream-close drop ;
M: pane with-stream-style ( quot style pane -- )
M: pane with-stream-style
(with-stream-style) ;
: ?terpri

6
library/ui/gadgets/paragraphs.factor
View File

@ -10,7 +10,7 @@ TUPLE: word-break-gadget ;
C: word-break-gadget ( gadget -- gadget )
[ set-delegate ] keep ;
M: word-break-gadget draw-gadget* ( gadget -- ) drop ;
M: word-break-gadget draw-gadget* drop ;
! A gadget that arranges its children in a word-wrap style.
TUPLE: paragraph margin ;
@ -61,8 +61,8 @@ SYMBOL: margin
[ wrap-step ] each-child-with wrap-dim
] with-scope ; inline
M: paragraph pref-dim* ( paragraph -- dim )
M: paragraph pref-dim*
[ 2drop ] do-wrap ;
M: paragraph layout* ( paragraph -- )
M: paragraph layout*
[ swap dup prefer set-rect-loc ] do-wrap drop ;

22
library/ui/gadgets/presentations.factor
View File

@ -18,7 +18,7 @@ C: object-button ( gadget object -- button )
r> set-gadget-delegate
] keep ;
M: object-button gadget-help ( button -- string )
M: object-button gadget-help
object-button-object dup word? [ synopsis ] [ summary ] if ;
! Character styles
@ -107,26 +107,26 @@ M: object-button gadget-help ( button -- string )
[ pick pick >r >r -rot styled-pane r> r> rot ] map
] map styled-grid nip ;
M: pane with-stream-table ( grid quot style pane -- )
M: pane with-stream-table
>r rot <pane-grid> r> print-gadget ;
M: pane with-nested-stream ( quot style stream -- )
M: pane with-nested-stream
>r styled-pane r> write-gadget ;
! Stream utilities
M: pack stream-close ( stream -- ) drop ;
M: pack stream-close drop ;
M: paragraph stream-close ( stream -- ) drop ;
M: paragraph stream-close drop ;
: gadget-write ( string gadget -- )
over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
M: pack stream-write ( string stream -- ) gadget-write ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
>r " " <presentation> <word-break-gadget> r> add-gadget ;
M: paragraph stream-write ( string stream -- )
M: paragraph stream-write
swap " " split
[ over gadget-write ] [ H{ } over gadget-bl ] interleave
drop ;
@ -134,9 +134,9 @@ M: paragraph stream-write ( string stream -- )
: gadget-write1 ( char gadget -- )
>r ch>string r> stream-write ;
M: pack stream-write1 ( char stream -- ) gadget-write1 ;
M: pack stream-write1 gadget-write1 ;
M: paragraph stream-write1 ( char stream -- )
M: paragraph stream-write1
over CHAR: \s =
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
@ -144,10 +144,10 @@ M: paragraph stream-write1 ( char stream -- )
pick empty?
[ 3drop ] [ >r swap <presentation> r> add-gadget ] if ;
M: pack stream-format ( string style stream -- )
M: pack stream-format
gadget-format ;
M: paragraph stream-format ( string style stream -- )
M: paragraph stream-format
presented pick hash [
gadget-format
] [

4
library/ui/gadgets/scrolling.factor
View File

@ -85,10 +85,10 @@ C: scroller ( gadget -- scroller )
dup scroller-origin scroll
] if ;
M: scroller layout* ( scroller -- )
M: scroller layout*
dup delegate layout*
dup layout-children
update-scroller ;
M: scroller focusable-child* ( scroller -- viewport )
M: scroller focusable-child*
scroller-viewport ;

2
library/ui/gadgets/sliders.factor
View File

@ -116,7 +116,7 @@ C: elevator ( vector -- elevator )
: layout-thumb ( slider -- )
dup layout-thumb-loc layout-thumb-dim ;
M: elevator layout* ( elevator -- )
M: elevator layout*
find-slider layout-thumb ;
: slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;

4
library/ui/gadgets/tracks.factor
View File

@ -32,14 +32,14 @@ C: track ( orientation -- track )
[ [ over n*v , ] [ divider-size , ] interleave ] { } make
nip ;
M: track layout* ( track -- )
M: track layout*
dup track-layout packed-layout ;
: track-pref-dims ( dims sizes -- dims )
[ [ dup zero? [ nip ] [ v/n ] if ] 2map max-dim ] keep
divider-sizes v+ [ >fixnum ] map ;
M: track pref-dim* ( track -- dim )
M: track pref-dim*
[
dup gadget-children
2 group [ first ] map pref-dims

6
library/ui/gadgets/viewports.factor
View File

@ -15,13 +15,13 @@ C: viewport ( content -- viewport )
[ >r 3 <border> r> add-gadget ] keep
t over set-gadget-clipped? ;
M: viewport layout* ( viewport -- )
M: viewport layout*
dup gadget-child dup pref-dim rot rect-dim vmax
swap set-layout-dim ;
M: viewport focusable-child* ( viewport -- gadget )
M: viewport focusable-child*
gadget-child ;
M: viewport pref-dim* ( viewport -- dim ) viewport-dim ;
M: viewport pref-dim* viewport-dim ;
: viewport-rect ( rect -- rect ) { 3 3 } offset-rect ;

6
library/ui/layouts.factor
View File

@ -141,16 +141,16 @@ C: pack ( vector -- pack )
[ >r [ max-dim ] keep r> pack-gap swap gap-dims ] keep
gadget-orientation set-axis ;
M: pack pref-dim* ( pack -- dim )
M: pack pref-dim*
[ gadget-children pref-dims ] keep pack-pref-dim ;
M: pack layout* ( pack -- )
M: pack layout*
dup gadget-children pref-dims packed-layout ;
: fast-children-on ( dim axis gadgets -- i )
swapd [ rect-loc v- over v. ] binsearch nip ;
M: pack children-on ( rect pack -- list )
M: pack children-on
dup gadget-orientation swap gadget-children [
3dup
>r >r dup rect-loc swap rect-dim v+ origin get v- r> r> fast-children-on 1+

16
library/ui/models.factor
View File

@ -56,7 +56,7 @@ GENERIC: model-changed ( observer -- )
GENERIC: set-model ( value model -- )
M: model set-model ( value model -- )
M: model set-model
[ set-model-value ] keep
model-connections [ model-changed ] each ;
@ -84,7 +84,7 @@ C: filter ( model quot -- filter )
[ add-dependency ] keep
dup model-changed ;
M: filter model-changed ( filter -- )
M: filter model-changed
dup filter-model model-value over filter-quot call
swap set-model ;
@ -97,7 +97,7 @@ C: validator ( model quot -- filter )
[ add-dependency ] keep
dup model-changed ;
M: validator model-changed ( validator -- )
M: validator model-changed
dup validator-model model-value dup
pick validator-quot call [
swap delegate set-model
@ -105,7 +105,7 @@ M: validator model-changed ( validator -- )
2drop
] if ;
M: validator set-model ( value validator -- )
M: validator set-model
2dup validator-quot call [
validator-model set-model
] [
@ -119,11 +119,11 @@ C: compose ( models -- compose )
[ set-model-dependencies ] keep
dup model-changed ;
M: compose model-changed ( compose -- )
M: compose model-changed
dup model-dependencies [ model-value ] map
swap delegate set-model ;
M: compose set-model ( value compose -- )
M: compose set-model
model-dependencies [ set-model ] 2each ;
TUPLE: history back forward ;
@ -136,7 +136,7 @@ C: history ( value -- history )
G: (add-history) ( history vector -- )
1 standard-combination ;
M: history (add-history) ( history vector -- )
M: history (add-history)
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
@ -152,6 +152,6 @@ M: history (add-history) ( history vector -- )
GENERIC: add-history ( history -- )
M: history add-history ( history -- )
M: history add-history
dup history-forward delete-all
dup history-back (add-history) ;

8
library/ui/paint.factor
View File

@ -25,7 +25,7 @@ SYMBOL: clip
GENERIC: draw-gadget* ( gadget -- )
M: gadget draw-gadget* ( gadget -- ) drop ;
M: gadget draw-gadget* drop ;
GENERIC: draw-interior ( gadget interior -- )
@ -94,7 +94,7 @@ M: solid draw-boundary
! Gradient pen
TUPLE: gradient colors ;
M: gradient draw-interior ( gadget gradient -- )
M: gradient draw-interior
over gadget-orientation swap gradient-colors rot rect-dim
gl-gradient ;
@ -104,10 +104,10 @@ TUPLE: polygon color points ;
: draw-polygon ( polygon quot -- )
>r dup polygon-color gl-color polygon-points r> each ; inline
M: polygon draw-boundary ( gadget polygon -- )
M: polygon draw-boundary
[ gl-poly ] draw-polygon drop ;
M: polygon draw-interior ( gadget polygon -- )
M: polygon draw-interior
[ gl-fill-poly ] draw-polygon drop ;
: arrow-up { { { 3 0 } { 6 6 } { 0 6 } } } ;

4
library/ui/text/document.factor
View File

@ -128,11 +128,11 @@ C: document ( -- document )
: clear-doc ( document -- )
"" swap set-doc-text ;
M: document (add-history) ( document vector -- )
M: document (add-history)
>r model-value dup { "" } sequence=
[ r> 2drop ] [ r> push-new ] if ;
M: document add-history ( document -- )
M: document add-history
#! Add the new entry at the end of the history, and avoid
#! duplicates.
dup history-back dup

18
library/ui/text/editor.factor
View File

@ -32,17 +32,17 @@ C: editor ( document -- editor )
: deactivate-editor-model ( editor model -- )
dup deactivate-model swap control-model remove-loc ;
M: editor graft* ( editor -- )
M: editor graft*
dup dup editor-caret activate-editor-model
dup dup editor-mark activate-editor-model
dup control-self swap control-model add-connection ;
M: editor ungraft* ( editor -- )
M: editor ungraft*
dup dup editor-caret deactivate-editor-model
dup dup editor-mark deactivate-editor-model
dup control-self swap control-model remove-connection ;
M: editor model-changed ( editor -- )
M: editor model-changed
control-self dup control-model
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
@ -124,7 +124,7 @@ M: editor model-changed ( editor -- )
: scroll>caret ( editor -- )
dup caret-rect swap scroll>rect ;
M: loc-monitor model-changed ( obj -- )
M: loc-monitor model-changed
loc-monitor-editor dup scroll>caret
control-self relayout ;
@ -182,7 +182,7 @@ M: loc-monitor model-changed ( obj -- )
] each-line 2drop
] do-matrix ;
M: editor draw-gadget* ( gadget -- )
M: editor draw-gadget*
[ draw-caret draw-selection draw-lines ] with-editor ;
: editor-height ( editor -- n )
@ -192,20 +192,20 @@ M: editor draw-gadget* ( gadget -- )
0 swap dup editor-font* swap editor-lines
[ string-width max ] each-with ;
M: editor pref-dim* ( editor -- dim )
M: editor pref-dim*
dup editor-width swap editor-height 2array ;
M: editor gadget-selection? ( editor -- ? )
M: editor gadget-selection?
selection-start/end = not ;
M: editor gadget-selection ( editor -- str )
M: editor gadget-selection
[ selection-start/end ] keep control-model doc-range ;
: remove-editor-selection ( editor -- )
[ selection-start/end ] keep control-model
remove-doc-range ;
M: editor user-input* ( str editor -- ? )
M: editor user-input*
[ selection-start/end ] keep control-model set-doc-range t ;
: editor-text ( editor -- str )

4
library/ui/text/interactor.factor
View File

@ -11,7 +11,7 @@ C: interactor ( output -- gadget )
f <field> over set-gadget-delegate
dup dup set-control-self ;
M: interactor graft* ( interactor -- )
M: interactor graft*
f over set-interactor-busy? delegate graft* ;
: interactor-eval ( string interactor -- )
@ -55,6 +55,6 @@ interactor H{
{ T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
} set-gestures
M: interactor stream-readln ( interactor -- line )
M: interactor stream-readln
f over set-interactor-busy?
[ over set-interactor-continuation stop ] callcc1 nip ;

4
library/ui/tools/browser.factor
View File

@ -164,6 +164,6 @@ M: browser gadget-title drop "Browser" <model> ;
: browser-tool [ browser? ] [ <browser> ] [ browse ] ;
M: word show ( word -- ) browser-tool call-tool ;
M: word show browser-tool call-tool ;
M: vocab-link show ( vocab -- ) browser-tool call-tool ;
M: vocab-link show browser-tool call-tool ;

2
library/ui/tools/help.factor
View File

@ -47,4 +47,4 @@ M: help-gadget pref-dim*
[ <help-gadget> ]
[ show-help ] ;
M: link show ( link -- ) help-tool call-tool ;
M: link show help-tool call-tool ;

6
library/ui/tools/listener.factor
View File

@ -51,7 +51,7 @@ C: listener-gadget ( -- gadget )
M: listener-gadget pref-dim*
delegate pref-dim* { 500 600 } vmax ;
M: listener-gadget focusable-child* ( listener -- gadget )
M: listener-gadget focusable-child*
listener-gadget-input ;
M: listener-gadget gadget-title drop "Listener" <model> ;
@ -81,8 +81,8 @@ M: listener-gadget gadget-title drop "Listener" <model> ;
[ [ run-file ] each ] curry listener-tool call-tool
] if ;
M: input show ( input -- )
M: input show
input-string listener-tool call-tool ;
M: object show ( object -- )
M: object show
[ inspect ] curry listener-tool call-tool ;

2
library/ui/tools/walker.factor
View File

@ -87,7 +87,7 @@ M: walker-gadget gadget-title
M: walker-gadget pref-dim*
delegate pref-dim* { 600 600 } vmax ;
M: walker-gadget focusable-child* ( listener -- gadget )
M: walker-gadget focusable-child*
walker-gadget-input ;
: walker-continuation ( -- continuation )

2
library/ui/ui.factor
View File

@ -153,7 +153,7 @@ C: world-error ( error world -- error )
[ set-world-error-world ] keep
[ set-delegate ] keep ;
M: world-error error. ( world-error -- )
M: world-error error.
"An error occurred while drawing the world " write
dup world-error-world pprint-short "." print
"This world has been deactivated to prevent cascading errors." print

4
library/ui/windows/clipboard.factor
View File

@ -45,8 +45,8 @@ IN: win32
CloseClipboard drop ;
TUPLE: pasteboard ;
M: pasteboard clipboard-contents ( pb -- str ) drop paste ;
M: pasteboard set-clipboard-contents ( str pb -- ) drop copy ;
M: pasteboard clipboard-contents drop paste ;
M: pasteboard set-clipboard-contents drop copy ;
: init-clipboard ( -- )
<pasteboard> clipboard set-global ;

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