Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
f18aef2afb
|
|
@ -35,83 +35,87 @@ gc
|
|||
: compile-unoptimized ( words -- )
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
"debug-compiler" get [
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
||||
! Compile a set of words ahead of the full compile.
|
||||
! This set of words was determined semi-empirically
|
||||
! using the profiler. It improves bootstrap time
|
||||
! significantly, because frequenly called words
|
||||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
not ?
|
||||
! Compile a set of words ahead of the full compile.
|
||||
! This set of words was determined semi-empirically
|
||||
! using the profiler. It improves bootstrap time
|
||||
! significantly, because frequenly called words
|
||||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
not ?
|
||||
|
||||
2over roll -roll
|
||||
2over roll -roll
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
quotation?
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
quotation?
|
||||
|
||||
curry compose uncurry
|
||||
curry compose uncurry
|
||||
|
||||
array-nth set-array-nth length>>
|
||||
array-nth set-array-nth length>>
|
||||
|
||||
wrap probe
|
||||
wrap probe
|
||||
|
||||
namestack*
|
||||
namestack*
|
||||
|
||||
layout-of
|
||||
} compile-unoptimized
|
||||
layout-of
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
bitand bitor bitxor bitnot
|
||||
} compile-unoptimized
|
||||
{
|
||||
bitand bitor bitxor bitnot
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
+ 2/ < <= > >= shift
|
||||
} compile-unoptimized
|
||||
{
|
||||
+ 2/ < <= > >= shift
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop last flip
|
||||
} compile-unoptimized
|
||||
{
|
||||
new-sequence nth push pop last flip
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
hashcode* = equal? assoc-stack (assoc-stack) get set
|
||||
} compile-unoptimized
|
||||
{
|
||||
hashcode* = equal? assoc-stack (assoc-stack) get set
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
memq? split harvest sift cut cut-slice start index clone
|
||||
set-at reverse push-all class number>string string>number
|
||||
like clone-like
|
||||
} compile-unoptimized
|
||||
{
|
||||
memq? split harvest sift cut cut-slice start index clone
|
||||
set-at reverse push-all class number>string string>number
|
||||
like clone-like
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
lines prefix suffix unclip new-assoc update
|
||||
word-prop set-word-prop 1array 2array 3array ?nth
|
||||
} compile-unoptimized
|
||||
{
|
||||
lines prefix suffix unclip new-assoc update
|
||||
word-prop set-word-prop 1array 2array 3array ?nth
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
} compile-unoptimized
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
vocabs [ words compile-unoptimized "." write flush ] each
|
||||
vocabs [ words compile-unoptimized "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
" done" print flush
|
||||
|
||||
] unless
|
||||
|
|
@ -38,11 +38,11 @@ IN: bootstrap.image
|
|||
|
||||
! Object cache; we only consider numbers equal if they have the
|
||||
! same type
|
||||
TUPLE: id obj ;
|
||||
TUPLE: eql-wrapper obj ;
|
||||
|
||||
C: <id> id
|
||||
C: <eql-wrapper> eql-wrapper
|
||||
|
||||
M: id hashcode* obj>> hashcode* ;
|
||||
M: eql-wrapper hashcode* obj>> hashcode* ;
|
||||
|
||||
GENERIC: (eql?) ( obj1 obj2 -- ? )
|
||||
|
||||
|
|
@ -62,19 +62,27 @@ M: sequence (eql?)
|
|||
|
||||
M: object (eql?) = ;
|
||||
|
||||
M: id equal?
|
||||
over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
||||
M: eql-wrapper equal?
|
||||
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
||||
|
||||
TUPLE: eq-wrapper obj ;
|
||||
|
||||
C: <eq-wrapper> eq-wrapper
|
||||
|
||||
M: eq-wrapper equal?
|
||||
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
|
||||
|
||||
SYMBOL: objects
|
||||
|
||||
: (objects) ( obj -- id assoc ) <id> objects get ; inline
|
||||
: cache-eql-object ( obj quot -- value )
|
||||
[ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
|
||||
|
||||
: lookup-object ( obj -- n/f ) (objects) at ;
|
||||
: cache-eq-object ( obj quot -- value )
|
||||
[ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
|
||||
|
||||
: put-object ( n obj -- ) (objects) set-at ;
|
||||
: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
|
||||
|
||||
: cache-object ( obj quot -- value )
|
||||
[ (objects) ] dip '[ obj>> @ ] cache ; inline
|
||||
: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
|
||||
|
||||
! Constants
|
||||
|
||||
|
|
@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
M: bignum '
|
||||
[
|
||||
bignum [ emit-bignum ] emit-object
|
||||
] cache-object ;
|
||||
] cache-eql-object ;
|
||||
|
||||
! Fixnums
|
||||
|
||||
|
|
@ -277,7 +285,7 @@ M: float '
|
|||
float [
|
||||
align-here double>bits emit-64
|
||||
] emit-object
|
||||
] cache-object ;
|
||||
] cache-eql-object ;
|
||||
|
||||
! Special objects
|
||||
|
||||
|
|
@ -340,7 +348,7 @@ M: word ' ;
|
|||
! Wrappers
|
||||
|
||||
M: wrapper '
|
||||
wrapped>> ' wrapper [ emit ] emit-object ;
|
||||
[ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
|
||||
|
||||
! Strings
|
||||
: native> ( object -- object )
|
||||
|
|
@ -379,7 +387,7 @@ M: wrapper '
|
|||
M: string '
|
||||
#! We pool strings so that each string is only written once
|
||||
#! to the image
|
||||
[ emit-string ] cache-object ;
|
||||
[ emit-string ] cache-eql-object ;
|
||||
|
||||
: assert-empty ( seq -- )
|
||||
length 0 assert= ;
|
||||
|
|
@ -390,10 +398,12 @@ M: string '
|
|||
] bi* ;
|
||||
|
||||
M: byte-array '
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
pad-bytes emit-bytes
|
||||
] emit-object ;
|
||||
[
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
pad-bytes emit-bytes
|
||||
] emit-object
|
||||
] cache-eq-object ;
|
||||
|
||||
! Tuples
|
||||
ERROR: tuple-removed class ;
|
||||
|
|
@ -408,20 +418,22 @@ ERROR: tuple-removed class ;
|
|||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
dup class name>> "tombstone" =
|
||||
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
|
||||
[ [ (emit-tuple) ] cache-eql-object ]
|
||||
[ [ (emit-tuple) ] cache-eq-object ]
|
||||
if ;
|
||||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tombstone '
|
||||
state>> "((tombstone))" "((empty))" ?
|
||||
"hashtables.private" lookup def>> first
|
||||
[ emit-tuple ] cache-object ;
|
||||
[ emit-tuple ] cache-eql-object ;
|
||||
|
||||
! Arrays
|
||||
: emit-array ( array -- offset )
|
||||
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
|
||||
M: array ' emit-array ;
|
||||
M: array ' [ emit-array ] cache-eq-object ;
|
||||
|
||||
! This is a hack. We need to detect arrays which are tuple
|
||||
! layout arrays so that they can be internalized, but making
|
||||
|
|
@ -438,7 +450,7 @@ M: tuple-layout-array '
|
|||
[
|
||||
[ dup integer? [ <fake-bignum> ] when ] map
|
||||
emit-array
|
||||
] cache-object ;
|
||||
] cache-eql-object ;
|
||||
|
||||
! Quotations
|
||||
|
||||
|
|
@ -452,7 +464,7 @@ M: quotation '
|
|||
0 emit ! xt
|
||||
0 emit ! code
|
||||
] emit-object
|
||||
] cache-object ;
|
||||
] cache-eql-object ;
|
||||
|
||||
! End of the image
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ IN: bootstrap.tools
|
|||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.deprecation"
|
||||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
|
|||
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
|
||||
compiler.cfg arrays locals byte-arrays kernel.private math
|
||||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
strings.private ;
|
||||
strings.private accessors compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
|
|
@ -157,3 +157,31 @@ IN: compiler.cfg.builder.tests
|
|||
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
|
||||
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
|
||||
] each
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
[ test-mr [ instructions>> ] map ] dip
|
||||
'[ _ any? ] any? ; inline
|
||||
|
||||
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
|
||||
[ ##set-alien-integer-1? ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 1000 [ ] times ]
|
||||
[ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
|
||||
] unit-test
|
||||
|
|
@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
|
|||
M: kill-block compute-in-set 3drop f ;
|
||||
|
||||
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
|
||||
bb dfa predecessors [ out-sets at ] map bb dfa join-sets ;
|
||||
! Only consider initialized sets.
|
||||
bb dfa predecessors
|
||||
[ out-sets key? ] filter
|
||||
[ out-sets at ] map
|
||||
bb dfa join-sets ;
|
||||
|
||||
:: update-in-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb out-sets dfa compute-in-set
|
||||
|
|
|
|||
|
|
@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
|
||||
: peek-loc ( loc -- vreg )
|
||||
translate-local-loc
|
||||
dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
|
||||
dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
|
||||
dup replace-mapping get at
|
||||
[ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
|
||||
|
||||
: replace-loc ( vreg loc -- )
|
||||
translate-local-loc
|
||||
2dup loc>vreg =
|
||||
[ nip replace-mapping get delete-at ]
|
||||
[
|
||||
[ local-replace-set get conjoin ]
|
||||
[ replace-mapping get set-at ]
|
||||
bi
|
||||
] if ;
|
||||
translate-local-loc replace-mapping get set-at ;
|
||||
|
||||
: compute-local-kill-set ( -- assoc )
|
||||
basic-block get current-height get
|
||||
|
|
@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
|
||||
: begin-local-analysis ( -- )
|
||||
H{ } clone local-peek-set set
|
||||
H{ } clone local-replace-set set
|
||||
H{ } clone replace-mapping set
|
||||
current-height get
|
||||
[ 0 >>emit-d 0 >>emit-r drop ]
|
||||
[ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
|
||||
|
||||
: remove-redundant-replaces ( -- )
|
||||
replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
|
||||
[ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
|
||||
|
||||
: end-local-analysis ( -- )
|
||||
remove-redundant-replaces
|
||||
emit-changes
|
||||
basic-block get {
|
||||
[ [ local-peek-set get ] dip peek-sets get set-at ]
|
||||
|
|
|
|||
|
|
@ -267,7 +267,7 @@ M: ##alien-global generate-insn
|
|||
%alien-global ;
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: next-fastcall-param ( reg-class -- )
|
||||
GENERIC: next-fastcall-param ( rep -- )
|
||||
|
||||
: ?dummy-stack-params ( rep -- )
|
||||
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
|
||||
|
|
@ -300,7 +300,7 @@ M: reg-class reg-class-full?
|
|||
stack-params dup ;
|
||||
|
||||
: alloc-fastcall-param ( rep -- n reg-class rep )
|
||||
[ reg-class-of [ get ] [ inc ] [ ] tri ] keep ;
|
||||
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
|
||||
|
||||
: alloc-parameter ( parameter -- reg rep )
|
||||
c-type-rep dup reg-class-of reg-class-full?
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
|
|||
quotations classes classes.algebra classes.tuple.private
|
||||
continuations growable namespaces hints alien.accessors
|
||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||
compiler definitions ;
|
||||
compiler definitions generic.single ;
|
||||
IN: compiler.tests.optimizer
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
|
|
@ -423,3 +423,6 @@ M: object bad-dispatch-position-test* ;
|
|||
\ bad-dispatch-position-test* forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Not sure if I want to fix this...
|
||||
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
|
||||
|
|
@ -4,7 +4,7 @@ USING: kernel kernel.private tools.test math math.partial-dispatch
|
|||
prettyprint math.private accessors slots.private sequences
|
||||
sequences.private strings sbufs compiler.tree.builder
|
||||
compiler.tree.normalization compiler.tree.debugger alien.accessors
|
||||
layouts combinators byte-arrays ;
|
||||
layouts combinators byte-arrays arrays ;
|
||||
IN: compiler.tree.modular-arithmetic.tests
|
||||
|
||||
: test-modular-arithmetic ( quot -- quot' )
|
||||
|
|
@ -134,7 +134,7 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >fixnum 255 >R R> fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
@ -201,6 +201,21 @@ cell {
|
|||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >bignum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
|
||||
{ fixnum+ } inlined?
|
||||
|
|
@ -257,4 +272,21 @@ cell {
|
|||
[ f ] [
|
||||
[ [ >fixnum ] 2dip set-alien-unsigned-1 ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 123 >bignum bitand >fixnum ]
|
||||
{ >bignum fixnum>bignum bignum-bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
! Shifts
|
||||
[ t ] [
|
||||
[
|
||||
[ 0 ] 2dip { array } declare [
|
||||
hashcode* >fixnum swap [
|
||||
[ -2 shift ] [ 5 shift ] bi
|
||||
+ +
|
||||
] keep bitxor >fixnum
|
||||
] with each
|
||||
] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
|
||||
] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.private math.partial-dispatch namespaces sequences
|
||||
sets accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit layouts alien.accessors
|
||||
USING: math math.intervals math.private math.partial-dispatch
|
||||
namespaces sequences sets accessors assocs words kernel memoize fry
|
||||
combinators combinators.short-circuit layouts alien.accessors
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -30,7 +30,7 @@ IN: compiler.tree.modular-arithmetic
|
|||
] each-integer-derived-op
|
||||
] each
|
||||
|
||||
{ bitand bitor bitxor bitnot >integer }
|
||||
{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
|
||||
[ t "modular-arithmetic" set-word-prop ] each
|
||||
|
||||
! Words that only use the low-order bits of their input. If the input
|
||||
|
|
@ -71,16 +71,28 @@ M: #push compute-modular-candidates*
|
|||
[ out-d>> first ] [ literal>> ] bi
|
||||
real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
|
||||
|
||||
: small-shift? ( interval -- ? )
|
||||
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
|
||||
|
||||
: modular-word? ( #call -- ? )
|
||||
dup word>> { shift fixnum-shift bignum-shift } memq?
|
||||
[ node-input-infos second interval>> small-shift? ]
|
||||
[ word>> "modular-arithmetic" word-prop ]
|
||||
if ;
|
||||
|
||||
: output-candidate ( #call -- )
|
||||
out-d>> first [ modular-value ] [ fixnum-value ] bi ;
|
||||
|
||||
: low-order-word? ( #call -- ? )
|
||||
word>> "low-order" word-prop ;
|
||||
|
||||
: input-candidiate ( #call -- )
|
||||
in-d>> first modular-value ;
|
||||
|
||||
M: #call compute-modular-candidates*
|
||||
{
|
||||
{
|
||||
[ dup word>> "modular-arithmetic" word-prop ]
|
||||
[ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
|
||||
}
|
||||
{
|
||||
[ dup word>> "low-order" word-prop ]
|
||||
[ in-d>> first modular-value ]
|
||||
}
|
||||
{ [ dup modular-word? ] [ output-candidate ] }
|
||||
{ [ dup low-order-word? ] [ input-candidiate ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -94,15 +106,13 @@ M: node compute-modular-candidates*
|
|||
|
||||
GENERIC: only-reads-low-order? ( node -- ? )
|
||||
|
||||
: output-modular? ( #call -- ? )
|
||||
out-d>> first modular-values get key? ;
|
||||
|
||||
M: #call only-reads-low-order?
|
||||
{
|
||||
[ word>> "low-order" word-prop ]
|
||||
[
|
||||
{
|
||||
[ word>> "modular-arithmetic" word-prop ]
|
||||
[ out-d>> first modular-values get key? ]
|
||||
} 1&&
|
||||
]
|
||||
[ low-order-word? ]
|
||||
[ { [ modular-word? ] [ output-modular? ] } 1&& ]
|
||||
} 1|| ;
|
||||
|
||||
M: node only-reads-low-order? drop f ;
|
||||
|
|
@ -162,22 +172,30 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
] when ;
|
||||
|
||||
: optimize-low-order-op ( #call -- nodes )
|
||||
dup in-d>> first fixnum-value? [
|
||||
dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
|
||||
[ ] [ in-d>> first ] [ info>> ] tri
|
||||
[ drop fixnum <class-info> ] change-at
|
||||
] when ;
|
||||
|
||||
: like->fixnum? ( #call -- ? )
|
||||
word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
|
||||
|
||||
: like->integer? ( #call -- ? )
|
||||
word>> { >integer >bignum fixnum>bignum } memq? ;
|
||||
|
||||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
{ [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
|
||||
[ drop ]
|
||||
{
|
||||
{ [ dup like->fixnum? ] [ optimize->fixnum ] }
|
||||
{ [ dup like->integer? ] [ optimize->integer ] }
|
||||
{ [ dup modular-word? ] [ optimize-modular-op ] }
|
||||
{ [ dup low-order-word? ] [ optimize-low-order-op ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: node optimize-modular-arithmetic* ;
|
||||
|
||||
: optimize-modular-arithmetic ( nodes -- nodes' )
|
||||
dup compute-modular-candidates compute-modular-values
|
||||
[ optimize-modular-arithmetic* ] map-nodes ;
|
||||
modular-values get assoc-empty? [
|
||||
[ optimize-modular-arithmetic* ] map-nodes
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -32,16 +32,20 @@ IN: compiler.tree.propagation.known-words
|
|||
|
||||
\ bitnot { integer } "input-classes" set-word-prop
|
||||
|
||||
: ?change-interval ( info quot -- quot' )
|
||||
over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
|
||||
: real-op ( info quot -- quot' )
|
||||
[
|
||||
dup class>> real classes-intersect?
|
||||
[ clone ] [ drop real <class-info> ] if
|
||||
] dip
|
||||
change-interval ; inline
|
||||
|
||||
{ bitnot fixnum-bitnot bignum-bitnot } [
|
||||
[ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
|
||||
[ [ interval-bitnot ] real-op ] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
|
||||
\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
|
||||
|
||||
\ absq [ [ interval-absq ] ?change-interval ] "outputs" set-word-prop
|
||||
\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ fixnum bignum integer rational float real number object }
|
||||
|
|
|
|||
|
|
@ -82,6 +82,8 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
|
@ -165,6 +167,10 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
|
|
|||
|
|
@ -38,6 +38,12 @@ IN: compiler.tree.propagation.transforms
|
|||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
: positive-fixnum? ( obj -- ? )
|
||||
{ [ fixnum? ] [ 0 >= ] } 1&& ;
|
||||
|
||||
: simplify-bitand? ( value -- ? )
|
||||
value-info literal>> positive-fixnum? ;
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
@ -45,10 +51,17 @@ IN: compiler.tree.propagation.transforms
|
|||
bitand
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
{
|
||||
{
|
||||
[ dup in-d>> first simplify-bitand? ]
|
||||
[ drop [ >fixnum fixnum-bitand ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> second simplify-bitand? ]
|
||||
[ drop [ [ >fixnum ] dip fixnum-bitand ] ]
|
||||
}
|
||||
[ drop f ]
|
||||
} cond
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
|
|||
|
|
@ -89,11 +89,8 @@ HOOK: reserved-area-size os ( -- n )
|
|||
: local@ ( n -- x )
|
||||
reserved-area-size param-save-size + + ; inline
|
||||
|
||||
: spill-integer@ ( n -- offset )
|
||||
spill-integer-offset local@ ;
|
||||
|
||||
: spill-float@ ( n -- offset )
|
||||
spill-float-offset local@ ;
|
||||
: spill@ ( n -- offset )
|
||||
spill-offset local@ ;
|
||||
|
||||
! Some FP intrinsics need a temporary scratch area in the stack
|
||||
! frame, 8 bytes in size. This is in the param-save area so it
|
||||
|
|
@ -275,9 +272,11 @@ M:: ppc %float>integer ( dst src -- )
|
|||
fp-scratch-reg 1 0 scratch@ STFD
|
||||
dst 1 4 scratch@ LWZ ;
|
||||
|
||||
M: ppc %copy ( dst src -- ) MR ;
|
||||
|
||||
M: ppc %copy-float ( dst src -- ) FMR ;
|
||||
M: ppc %copy ( dst src rep -- )
|
||||
{
|
||||
{ int-rep [ MR ] }
|
||||
{ double-float-rep [ FMR ] }
|
||||
} case ;
|
||||
|
||||
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
|
||||
|
||||
|
|
@ -478,11 +477,29 @@ M: ppc %compare-branch (%compare) %branch ;
|
|||
M: ppc %compare-imm-branch (%compare-imm) %branch ;
|
||||
M: ppc %compare-float-branch (%compare-float) %branch ;
|
||||
|
||||
M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
|
||||
M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
|
||||
: load-from-frame ( dst n rep -- )
|
||||
{
|
||||
{ int-rep [ [ 1 ] dip LWZ ] }
|
||||
{ single-float-rep [ [ 1 ] dip LFS ] }
|
||||
{ double-float-rep [ [ 1 ] dip LFD ] }
|
||||
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
|
||||
} case ;
|
||||
|
||||
M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
|
||||
M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
|
||||
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
|
||||
|
||||
: store-to-frame ( src n rep -- )
|
||||
{
|
||||
{ int-rep [ [ 1 ] dip STW ] }
|
||||
{ single-float-rep [ [ 1 ] dip STFS ] }
|
||||
{ double-float-rep [ [ 1 ] dip STFD ] }
|
||||
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
|
||||
} case ;
|
||||
|
||||
M: ppc %spill ( src n rep -- )
|
||||
[ spill@ ] dip store-to-frame ;
|
||||
|
||||
M: ppc %reload ( dst n rep -- )
|
||||
[ spill@ ] dip load-from-frame ;
|
||||
|
||||
M: ppc %loop-entry ;
|
||||
|
||||
|
|
@ -490,26 +507,11 @@ M: int-regs return-reg drop 3 ;
|
|||
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
|
||||
M: float-regs return-reg drop 1 ;
|
||||
|
||||
M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
||||
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
|
||||
M:: ppc %save-param-reg ( stack reg rep -- )
|
||||
reg stack local@ rep store-to-frame ;
|
||||
|
||||
M: single-float-rep %save-param-reg drop 1 rot local@ STFS ;
|
||||
M: single-float-rep %load-param-reg 1 rot local@ LFS ;
|
||||
|
||||
M: double-float-rep %save-param-reg drop 1 rot local@ STFD ;
|
||||
M: double-float-rep %load-param-reg 1 rot local@ LFD ;
|
||||
|
||||
M: stack-params %load-param-reg ( stack reg rep -- )
|
||||
drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
|
||||
|
||||
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
|
||||
|
||||
M: stack-params %save-param-reg ( stack reg rep -- )
|
||||
#! Funky. Read the parameter from the caller's stack frame.
|
||||
#! This word is used in callbacks
|
||||
drop
|
||||
[ 0 1 ] dip next-param@ LWZ
|
||||
[ 0 1 ] dip local@ STW ;
|
||||
M:: ppc %load-param-reg ( stack reg rep -- )
|
||||
reg stack local@ rep load-from-frame ;
|
||||
|
||||
M: ppc %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
|
|
|
|||
|
|
@ -288,6 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
|
|||
{ $subsection "prettyprint" }
|
||||
{ $subsection "inspector" }
|
||||
{ $subsection "tools.annotations" }
|
||||
{ $subsection "tools.deprecation" }
|
||||
{ $subsection "tools.inference" }
|
||||
{ $heading "Browsing" }
|
||||
{ $subsection "see" }
|
||||
|
|
|
|||
|
|
@ -295,4 +295,4 @@ M: no-match summary drop "Fall through in switch" ;
|
|||
reverse [ [ [undo] ] dip compose ] { } assoc>map
|
||||
recover-chain ;
|
||||
|
||||
MACRO: switch ( quot-alist -- ) [switch] ;
|
||||
MACRO: switch ( quot-alist -- ) [switch] ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien.syntax alien.c-types core-foundation
|
||||
core-foundation.bundles core-foundation.dictionaries system
|
||||
combinators kernel sequences debugger io accessors ;
|
||||
combinators kernel sequences io accessors ;
|
||||
IN: iokit
|
||||
|
||||
<<
|
||||
|
|
@ -136,11 +136,9 @@ FUNCTION: IOReturn IORegistryEntryCreateCFProperties ( io_registry_entry_t entry
|
|||
|
||||
FUNCTION: char* mach_error_string ( IOReturn error ) ;
|
||||
|
||||
TUPLE: mach-error error-code ;
|
||||
C: <mach-error> mach-error
|
||||
|
||||
M: mach-error error.
|
||||
"IOKit call failed: " print error-code>> mach_error_string print ;
|
||||
TUPLE: mach-error error-code error-string ;
|
||||
: <mach-error> ( code -- error )
|
||||
dup mach_error_string \ mach-error boa ;
|
||||
|
||||
: mach-error ( return -- )
|
||||
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@ HELP: interval-bitnot
|
|||
{ $description "Computes the bitwise complement of the interval." } ;
|
||||
|
||||
HELP: points>interval
|
||||
{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } }
|
||||
{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } { "nan?" "true if the computation produced NaNs" } }
|
||||
{ $description "Outputs the smallest interval containing all of the endpoints." }
|
||||
;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,6 +23,10 @@ IN: math.intervals.tests
|
|||
|
||||
[ T{ interval f { 1 t } { 1 t } } ] [ 1 [a,a] ] unit-test
|
||||
|
||||
! Not sure how to handle NaNs yet...
|
||||
! [ 1 0/0. [a,b] ] must-fail
|
||||
! [ 0/0. 1 [a,b] ] must-fail
|
||||
|
||||
[ t ] [ { 3 t } { 3 f } endpoint< ] unit-test
|
||||
[ t ] [ { 2 f } { 3 f } endpoint< ] unit-test
|
||||
[ f ] [ { 3 f } { 3 t } endpoint< ] unit-test
|
||||
|
|
@ -350,6 +354,10 @@ comparison-ops [
|
|||
|
||||
[ t ] [ full-interval interval-abs [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [0,inf] interval-abs [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ empty-interval interval-abs empty-interval = ] unit-test
|
||||
|
||||
[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test
|
||||
|
||||
! Test that commutative interval ops really are
|
||||
|
|
|
|||
|
|
@ -124,29 +124,31 @@ M: pathname pprint*
|
|||
] if
|
||||
] if ; inline
|
||||
|
||||
: tuple>assoc ( tuple -- assoc )
|
||||
[ class all-slots ] [ tuple-slots ] bi zip
|
||||
: filter-tuple-assoc ( slot,value -- name,value )
|
||||
[ [ initial>> ] dip = not ] assoc-filter
|
||||
[ [ name>> ] dip ] assoc-map ;
|
||||
|
||||
: tuple>assoc ( tuple -- assoc )
|
||||
[ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
|
||||
|
||||
: pprint-slot-value ( name value -- )
|
||||
<flow \ { pprint-word
|
||||
[ text ] [ f <inset pprint* block> ] bi*
|
||||
\ } pprint-word block> ;
|
||||
|
||||
: (pprint-tuple) ( opener class slots closer -- )
|
||||
<flow {
|
||||
[ pprint-word ]
|
||||
[ pprint-word ]
|
||||
[ t <inset [ pprint-slot-value ] assoc-each block> ]
|
||||
[ pprint-word ]
|
||||
} spread block> ;
|
||||
|
||||
: ?pprint-tuple ( tuple quot -- )
|
||||
[ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
|
||||
|
||||
: pprint-tuple ( tuple -- )
|
||||
boa-tuples? get [ pprint-object ] [
|
||||
[
|
||||
<flow
|
||||
\ T{ pprint-word
|
||||
dup class pprint-word
|
||||
t <inset
|
||||
tuple>assoc [ pprint-slot-value ] assoc-each
|
||||
block>
|
||||
\ } pprint-word
|
||||
block>
|
||||
] check-recursion
|
||||
] if ;
|
||||
[ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
|
||||
|
||||
M: tuple pprint*
|
||||
pprint-tuple ;
|
||||
|
|
@ -177,16 +179,17 @@ M: callstack pprint-delims drop \ CS{ \ } ;
|
|||
M: object >pprint-sequence ;
|
||||
M: vector >pprint-sequence ;
|
||||
M: byte-vector >pprint-sequence ;
|
||||
M: curry >pprint-sequence ;
|
||||
M: compose >pprint-sequence ;
|
||||
M: callable >pprint-sequence ;
|
||||
M: hashtable >pprint-sequence >alist ;
|
||||
M: wrapper >pprint-sequence wrapped>> 1array ;
|
||||
M: callstack >pprint-sequence callstack>array ;
|
||||
|
||||
M: tuple >pprint-sequence
|
||||
[ class ] [ tuple-slots ] bi
|
||||
: class-slot-sequence ( class slots -- sequence )
|
||||
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
|
||||
|
||||
M: tuple >pprint-sequence
|
||||
[ class ] [ tuple-slots ] bi class-slot-sequence ;
|
||||
|
||||
M: object pprint-narrow? drop f ;
|
||||
M: byte-vector pprint-narrow? drop f ;
|
||||
M: array pprint-narrow? drop t ;
|
||||
|
|
|
|||
|
|
@ -101,6 +101,7 @@ M: object declarations. drop ;
|
|||
M: word declarations.
|
||||
{
|
||||
POSTPONE: delimiter
|
||||
POSTPONE: deprecated
|
||||
POSTPONE: inline
|
||||
POSTPONE: recursive
|
||||
POSTPONE: foldable
|
||||
|
|
@ -229,4 +230,4 @@ PRIVATE>
|
|||
] { } make prune ;
|
||||
|
||||
: see-methods ( word -- )
|
||||
methods see-all nl ;
|
||||
methods see-all nl ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors sequences sequences.private kernel words classes
|
||||
math alien alien.c-types byte-arrays accessors
|
||||
specialized-arrays ;
|
||||
specialized-arrays prettyprint.custom ;
|
||||
IN: specialized-arrays.direct.functor
|
||||
|
||||
FUNCTOR: define-direct-array ( T -- )
|
||||
|
|
@ -10,6 +10,7 @@ FUNCTOR: define-direct-array ( T -- )
|
|||
A' IS ${T}-array
|
||||
>A' IS >${T}-array
|
||||
<A'> IS <${A'}>
|
||||
A'{ IS ${A'}{
|
||||
|
||||
A DEFINES-CLASS direct-${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
|
|
@ -30,6 +31,12 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
|
|||
M: A like drop dup A instance? [ >A' ] unless ;
|
||||
M: A new-sequence drop <A'> ;
|
||||
|
||||
M: A pprint-delims drop \ A'{ \ } ;
|
||||
|
||||
M: A >pprint-sequence ;
|
||||
|
||||
M: A pprint* pprint-object ;
|
||||
|
||||
INSTANCE: A sequence
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
IN: tools.continuations
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
HELP: break
|
||||
{ $description "A breakpoint. When this word is executed, the walker tool opens with execution suspended at the breakpoint's location." }
|
||||
{ $see-also "ui-walker" } ;
|
||||
|
|
@ -202,17 +202,37 @@ IN: tools.deploy.shaker
|
|||
[ dup implementors [ "methods" word-prop delete-at ] with each ] each
|
||||
] when ;
|
||||
|
||||
: recursive-subst ( seq old new -- )
|
||||
'[
|
||||
_ _
|
||||
{
|
||||
! old becomes new
|
||||
{ [ 3dup drop eq? ] [ 2nip ] }
|
||||
! recurse into arrays
|
||||
{ [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
|
||||
! otherwise do nothing
|
||||
[ 2drop ]
|
||||
} cond
|
||||
] change-each ;
|
||||
|
||||
: strip-default-method ( generic new-default -- )
|
||||
[
|
||||
[ "decision-tree" word-prop ]
|
||||
[ "default-method" word-prop ] bi
|
||||
] dip
|
||||
recursive-subst ;
|
||||
|
||||
: new-default-method ( -- gensym )
|
||||
[ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
|
||||
|
||||
: strip-default-methods ( -- )
|
||||
! In a development image, each generic has its own default method.
|
||||
! This gives better error messages for runtime type errors, but
|
||||
! takes up space. For deployment we merge them all together.
|
||||
strip-debugger? [
|
||||
"Stripping default methods" show
|
||||
[
|
||||
[ generic? ] instances
|
||||
[ "No method" throw ] (( -- * )) define-temp
|
||||
dup t "default" set-word-prop
|
||||
'[
|
||||
[ _ "default-method" set-word-prop ] [ make-generic ] bi
|
||||
] each
|
||||
] with-compilation-unit
|
||||
[ single-generic? ] instances
|
||||
new-default-method '[ _ strip-default-method ] each
|
||||
] when ;
|
||||
|
||||
: strip-vocab-globals ( except names -- words )
|
||||
|
|
@ -361,8 +381,8 @@ IN: tools.deploy.shaker
|
|||
[ compress-object? ] [ ] "objects" compress ;
|
||||
|
||||
: remain-compiled ( old new -- old new )
|
||||
#! Quotations which were formerly compiled must remain
|
||||
#! compiled.
|
||||
! Quotations which were formerly compiled must remain
|
||||
! compiled.
|
||||
2dup [
|
||||
2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
|
||||
[ nip jit-compile ] [ 2drop ] if
|
||||
|
|
@ -383,7 +403,9 @@ SYMBOL: deploy-vocab
|
|||
[ boot ] %
|
||||
init-hooks get values concat %
|
||||
strip-debugger? [ , ] [
|
||||
! Don't reference try directly
|
||||
! Don't reference 'try' directly since we don't want
|
||||
! to pull in the debugger and prettyprinter into every
|
||||
! deployed app
|
||||
[:c]
|
||||
[print-error]
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ IN: debugger
|
|||
"threads" vocab [
|
||||
[
|
||||
"error-in-thread" "threads" lookup
|
||||
[ die 2drop ]
|
||||
define
|
||||
[ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
|
||||
] with-compilation-unit
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: help.markup help.syntax kernel words ;
|
||||
IN: tools.deprecation
|
||||
|
||||
HELP: :deprecations
|
||||
{ $description "Prints all deprecation notes." } ;
|
||||
|
||||
ARTICLE: "tools.deprecation" "Deprecation tracking"
|
||||
"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words."
|
||||
{ $subsection POSTPONE: deprecated }
|
||||
{ $subsection :deprecations } ;
|
||||
|
||||
ABOUT: "tools.deprecation"
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays assocs compiler.units
|
||||
debugger init io kernel namespaces prettyprint sequences
|
||||
source-files.errors summary tools.crossref
|
||||
tools.crossref.private tools.errors words ;
|
||||
IN: tools.deprecation
|
||||
|
||||
SYMBOL: +deprecation-note+
|
||||
SYMBOL: deprecation-notes
|
||||
|
||||
deprecation-notes [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: deprecation-note < source-file-error ;
|
||||
|
||||
M: deprecation-note error-type drop +deprecation-note+ ;
|
||||
|
||||
TUPLE: deprecated-usages asset usages ;
|
||||
|
||||
: :deprecations ( -- )
|
||||
deprecation-notes get-global values errors. ;
|
||||
|
||||
T{ error-type
|
||||
{ type +deprecation-note+ }
|
||||
{ word ":deprecations" }
|
||||
{ plural "deprecated word usages" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
|
||||
{ quot [ deprecation-notes get values ] }
|
||||
{ forget-quot [ deprecation-notes get delete-at ] }
|
||||
} define-error-type
|
||||
|
||||
: <deprecation-note> ( error word -- deprecation-note )
|
||||
\ deprecation-note <definition-error> ;
|
||||
|
||||
: deprecation-note ( word usages -- )
|
||||
[ deprecated-usages boa ]
|
||||
[ drop <deprecation-note> ]
|
||||
[ drop deprecation-notes get-global set-at ] 2tri ;
|
||||
|
||||
: clear-deprecation-note ( word -- )
|
||||
deprecation-notes get-global delete-at ;
|
||||
|
||||
: check-deprecations ( word -- )
|
||||
dup "forgotten" word-prop
|
||||
[ clear-deprecation-note ] [
|
||||
dup def>> uses [ deprecated? ] filter
|
||||
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
|
||||
] if ;
|
||||
|
||||
M: deprecated-usages summary
|
||||
drop "Deprecated words used" ;
|
||||
|
||||
M: deprecated-usages error.
|
||||
"The definition of " write
|
||||
dup asset>> pprint
|
||||
" uses these deprecated words:" write nl
|
||||
usages>> [ " " write pprint nl ] each ;
|
||||
|
||||
SINGLETON: deprecation-observer
|
||||
|
||||
: initialize-deprecation-notes ( -- )
|
||||
get-crossref [ drop deprecated? ] assoc-filter
|
||||
values [ keys [ check-deprecations ] each ] each ;
|
||||
|
||||
M: deprecation-observer definitions-changed
|
||||
drop keys [ word? ] filter
|
||||
dup [ deprecated? ] filter empty?
|
||||
[ [ check-deprecations ] each ]
|
||||
[ drop initialize-deprecation-notes ] if ;
|
||||
|
||||
[ \ deprecation-observer add-definition-observer ]
|
||||
"tools.deprecation" add-init-hook
|
||||
|
||||
initialize-deprecation-notes
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tracking usage of deprecated words
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
IN: tools.walker
|
||||
USING: help.syntax help.markup tools.continuations ;
|
||||
|
||||
HELP: B
|
||||
{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;
|
||||
|
|
@ -14,6 +14,7 @@ $nl
|
|||
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } "Deprecated words used" { $link "tools.deprecation" } }
|
||||
} ;
|
||||
|
||||
ABOUT: "ui.tools.error-list"
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -28,6 +28,7 @@ ARTICLE: "breakpoints" "Setting breakpoints"
|
|||
$nl
|
||||
"Breakpoints can be inserted directly into code:"
|
||||
{ $subsection break }
|
||||
{ $subsection POSTPONE: B }
|
||||
"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;
|
||||
|
||||
ARTICLE: "ui-walker" "UI walker"
|
||||
|
|
|
|||
|
|
@ -67,6 +67,7 @@ IN: bootstrap.syntax
|
|||
"M\\"
|
||||
"]"
|
||||
"delimiter"
|
||||
"deprecated"
|
||||
"f"
|
||||
"flushable"
|
||||
"foldable"
|
||||
|
|
|
|||
|
|
@ -87,22 +87,24 @@ ERROR: bad-literal-tuple ;
|
|||
: parse-slot-values ( -- values )
|
||||
[ (parse-slot-values) ] { } make ;
|
||||
|
||||
: boa>tuple ( class slots -- tuple )
|
||||
GENERIC# boa>object 1 ( class slots -- tuple )
|
||||
|
||||
M: tuple-class boa>object
|
||||
swap prefix >tuple ;
|
||||
|
||||
: assoc>tuple ( class slots -- tuple )
|
||||
[ [ ] [ initial-values ] [ all-slots ] tri ] dip
|
||||
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
|
||||
[ dup <enum> ] dip update boa>tuple ;
|
||||
: assoc>object ( class slots values -- tuple )
|
||||
[ [ [ initial>> ] map ] keep ] dip
|
||||
swap [ [ slot-named* drop ] curry dip ] curry assoc-map
|
||||
[ dup <enum> ] dip update boa>object ;
|
||||
|
||||
: parse-tuple-literal-slots ( class -- tuple )
|
||||
: parse-tuple-literal-slots ( class slots -- tuple )
|
||||
scan {
|
||||
{ f [ unexpected-eof ] }
|
||||
{ "f" [ \ } parse-until boa>tuple ] }
|
||||
{ "{" [ parse-slot-values assoc>tuple ] }
|
||||
{ "}" [ new ] }
|
||||
{ "f" [ drop \ } parse-until boa>object ] }
|
||||
{ "{" [ parse-slot-values assoc>object ] }
|
||||
{ "}" [ drop new ] }
|
||||
[ bad-literal-tuple ]
|
||||
} case ;
|
||||
|
||||
: parse-tuple-literal ( -- tuple )
|
||||
scan-word parse-tuple-literal-slots ;
|
||||
scan-word dup all-slots parse-tuple-literal-slots ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.private ;
|
||||
IN: math.floats.private
|
||||
|
|
@ -28,3 +28,37 @@ M: float /i float/f >integer ; inline
|
|||
M: float mod float-mod ; inline
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ; inline
|
||||
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits 52 2^ 1 - bitand ; inline
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float next-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
|
||||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: float prev-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
|
||||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -97,55 +97,18 @@ GENERIC: fp-snan? ( x -- ? )
|
|||
GENERIC: fp-infinity? ( x -- ? )
|
||||
GENERIC: fp-nan-payload ( x -- bits )
|
||||
|
||||
M: object fp-special?
|
||||
drop f ; inline
|
||||
M: object fp-nan?
|
||||
drop f ; inline
|
||||
M: object fp-qnan?
|
||||
drop f ; inline
|
||||
M: object fp-snan?
|
||||
drop f ; inline
|
||||
M: object fp-infinity?
|
||||
drop f ; inline
|
||||
M: object fp-nan-payload
|
||||
drop f ; inline
|
||||
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits HEX: fffffffffffff bitand ; inline
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
|
||||
M: object fp-special? drop f ; inline
|
||||
M: object fp-nan? drop f ; inline
|
||||
M: object fp-qnan? drop f ; inline
|
||||
M: object fp-snan? drop f ; inline
|
||||
M: object fp-infinity? drop f ; inline
|
||||
M: object fp-nan-payload drop f ; inline
|
||||
|
||||
: <fp-nan> ( payload -- nan )
|
||||
HEX: 7ff0000000000000 bitor bits>double ; inline
|
||||
|
||||
: next-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
|
||||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: prev-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
|
||||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; inline
|
||||
GENERIC: next-float ( m -- n )
|
||||
GENERIC: prev-float ( m -- n )
|
||||
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
|
||||
|
|
|
|||
|
|
@ -25,6 +25,14 @@ unit-test
|
|||
[ "e" string>number ]
|
||||
unit-test
|
||||
|
||||
[ 100000 ]
|
||||
[ "100,000" string>number ]
|
||||
unit-test
|
||||
|
||||
[ 100000.0 ]
|
||||
[ "100,000.0" string>number ]
|
||||
unit-test
|
||||
|
||||
[ "100.0" ]
|
||||
[ "1.0e2" string>number number>string ]
|
||||
unit-test
|
||||
|
|
|
|||
|
|
@ -28,13 +28,16 @@ IN: math.parser
|
|||
{ CHAR: d 13 }
|
||||
{ CHAR: e 14 }
|
||||
{ CHAR: f 15 }
|
||||
} at 255 or ; inline
|
||||
{ CHAR: , f }
|
||||
} at* [ drop 255 ] unless ; inline
|
||||
|
||||
: string>digits ( str -- digits )
|
||||
[ digit> ] B{ } map-as ; inline
|
||||
|
||||
: (digits>integer) ( valid? accum digit radix -- valid? accum )
|
||||
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
|
||||
over [
|
||||
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
|
||||
] [ 2drop ] if ; inline
|
||||
|
||||
: each-digit ( seq radix quot -- n/f )
|
||||
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
|
||||
|
|
@ -80,6 +83,7 @@ SYMBOL: negative?
|
|||
] if ; inline
|
||||
|
||||
: string>float ( str -- n/f )
|
||||
[ CHAR: , eq? not ] filter
|
||||
>byte-array 0 suffix (string>float) ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -32,3 +32,10 @@ M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ;
|
|||
T{ protocol-slot-test-tuple { x 3 } } clone
|
||||
[ 7 + ] change-my-protocol-slot-test x>>
|
||||
] unit-test
|
||||
|
||||
UNION: comme-ci integer float ;
|
||||
UNION: comme-ca integer float ;
|
||||
comme-ca 25.5 "initial-value" set-word-prop
|
||||
|
||||
[ 0 ] [ comme-ci initial-value ] unit-test
|
||||
[ 25.5 ] [ comme-ca initial-value ] unit-test
|
||||
|
|
|
|||
|
|
@ -166,6 +166,7 @@ M: class initial-value* no-initial-value ;
|
|||
|
||||
: initial-value ( class -- object )
|
||||
{
|
||||
{ [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] }
|
||||
{ [ \ f bootstrap-word over class<= ] [ f ] }
|
||||
{ [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
|
||||
{ [ float bootstrap-word over class<= ] [ 0.0 ] }
|
||||
|
|
@ -233,5 +234,8 @@ M: slot-spec make-slot
|
|||
: finalize-slots ( specs base -- specs )
|
||||
over length iota [ + ] with map [ >>offset ] 2map ;
|
||||
|
||||
: slot-named* ( name specs -- offset spec/f )
|
||||
[ name>> = ] with find ;
|
||||
|
||||
: slot-named ( name specs -- spec/f )
|
||||
[ name>> = ] with find nip ;
|
||||
slot-named* nip ;
|
||||
|
|
|
|||
|
|
@ -191,6 +191,10 @@ HELP: delimiter
|
|||
{ $syntax ": foo ... ; delimiter" }
|
||||
{ $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ;
|
||||
|
||||
HELP: deprecated
|
||||
{ $syntax ": foo ... ; deprecated" }
|
||||
{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ;
|
||||
|
||||
HELP: SYNTAX:
|
||||
{ $syntax "SYNTAX: foo ... ;" }
|
||||
{ $description "Defines a parsing word." }
|
||||
|
|
|
|||
|
|
@ -111,6 +111,7 @@ IN: bootstrap.syntax
|
|||
"foldable" [ word make-foldable ] define-core-syntax
|
||||
"flushable" [ word make-flushable ] define-core-syntax
|
||||
"delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
|
||||
"deprecated" [ word make-deprecated ] define-core-syntax
|
||||
|
||||
"SYNTAX:" [
|
||||
CREATE-WORD parse-definition define-syntax
|
||||
|
|
|
|||
|
|
@ -294,6 +294,16 @@ HELP: delimiter?
|
|||
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
|
||||
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
|
||||
|
||||
HELP: deprecated?
|
||||
{ $values { "obj" object } { "?" "a boolean" } }
|
||||
{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." }
|
||||
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
|
||||
|
||||
HELP: make-deprecated
|
||||
{ $values { "word" word } }
|
||||
{ $description "Declares a word as " { $link POSTPONE: deprecated } "." }
|
||||
{ $side-effects "word" } ;
|
||||
|
||||
HELP: make-flushable
|
||||
{ $values { "word" word } }
|
||||
{ $description "Declares a word as " { $link POSTPONE: flushable } "." }
|
||||
|
|
|
|||
|
|
@ -123,6 +123,9 @@ M: word subwords drop f ;
|
|||
: define-declared ( word def effect -- )
|
||||
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
|
||||
|
||||
: make-deprecated ( word -- )
|
||||
t "deprecated" set-word-prop ;
|
||||
|
||||
: make-inline ( word -- )
|
||||
dup inline? [ drop ] [
|
||||
[ t "inline" set-word-prop ]
|
||||
|
|
@ -148,7 +151,7 @@ M: word reset-word
|
|||
{
|
||||
"unannotated-def" "parsing" "inline" "recursive"
|
||||
"foldable" "flushable" "reading" "writing" "reader"
|
||||
"writer" "delimiter"
|
||||
"writer" "delimiter" "deprecated"
|
||||
} reset-props ;
|
||||
|
||||
: reset-generic ( word -- )
|
||||
|
|
@ -200,6 +203,9 @@ M: parsing-word definer drop \ SYNTAX: \ ; ;
|
|||
: delimiter? ( obj -- ? )
|
||||
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
|
||||
|
||||
: deprecated? ( obj -- ? )
|
||||
dup word? [ "deprecated" word-prop ] [ drop f ] if ;
|
||||
|
||||
! Definition protocol
|
||||
M: word where "loc" word-prop ;
|
||||
|
||||
|
|
@ -217,4 +223,4 @@ M: word hashcode*
|
|||
|
||||
M: word literalize <wrapper> ;
|
||||
|
||||
INSTANCE: word definition
|
||||
INSTANCE: word definition
|
||||
|
|
|
|||
|
|
@ -0,0 +1,72 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: alien arrays classes help.markup help.syntax kernel math
|
||||
specialized-arrays.direct ;
|
||||
IN: classes.c-types
|
||||
|
||||
HELP: c-type-class
|
||||
{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
|
||||
|
||||
HELP: char
|
||||
{ $class-description "A signed one-byte integer quantity." } ;
|
||||
|
||||
HELP: direct-array-of
|
||||
{ $values
|
||||
{ "alien" c-ptr } { "len" integer } { "class" c-type-class }
|
||||
{ "array" "a direct array" }
|
||||
}
|
||||
{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
|
||||
|
||||
HELP: int
|
||||
{ $class-description "A signed four-byte integer quantity." } ;
|
||||
|
||||
HELP: long
|
||||
{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
|
||||
|
||||
HELP: longlong
|
||||
{ $class-description "A signed eight-byte integer quantity." } ;
|
||||
|
||||
HELP: short
|
||||
{ $class-description "A signed two-byte integer quantity." } ;
|
||||
|
||||
HELP: single-complex
|
||||
{ $class-description "A single-precision complex floating point quantity." } ;
|
||||
|
||||
HELP: single-float
|
||||
{ $class-description "A single-precision floating point quantity." } ;
|
||||
|
||||
HELP: uchar
|
||||
{ $class-description "An unsigned one-byte integer quantity." } ;
|
||||
|
||||
HELP: uint
|
||||
{ $class-description "An unsigned four-byte integer quantity." } ;
|
||||
|
||||
HELP: ulong
|
||||
{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
|
||||
|
||||
HELP: ulonglong
|
||||
{ $class-description "An unsigned eight-byte integer quantity." } ;
|
||||
|
||||
HELP: ushort
|
||||
{ $class-description "An unsigned two-byte integer quantity." } ;
|
||||
|
||||
ARTICLE: "classes.c-types" "C type classes"
|
||||
"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
|
||||
{ $subsection char }
|
||||
{ $subsection uchar }
|
||||
{ $subsection short }
|
||||
{ $subsection ushort }
|
||||
{ $subsection int }
|
||||
{ $subsection uint }
|
||||
{ $subsection long }
|
||||
{ $subsection ulong }
|
||||
{ $subsection longlong }
|
||||
{ $subsection ulonglong }
|
||||
{ $subsection single-float }
|
||||
{ $subsection float }
|
||||
{ $subsection single-complex }
|
||||
{ $subsection complex }
|
||||
{ $subsection pinned-c-ptr }
|
||||
"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
|
||||
{ $subsection direct-array-of } ;
|
||||
|
||||
ABOUT: "classes.c-types"
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: alien alien.c-types classes classes.predicate kernel
|
||||
math math.bitwise math.order namespaces sequences words
|
||||
specialized-arrays.direct.alien
|
||||
specialized-arrays.direct.bool
|
||||
specialized-arrays.direct.char
|
||||
specialized-arrays.direct.complex-double
|
||||
specialized-arrays.direct.complex-float
|
||||
specialized-arrays.direct.double
|
||||
specialized-arrays.direct.float
|
||||
specialized-arrays.direct.int
|
||||
specialized-arrays.direct.long
|
||||
specialized-arrays.direct.longlong
|
||||
specialized-arrays.direct.short
|
||||
specialized-arrays.direct.uchar
|
||||
specialized-arrays.direct.uint
|
||||
specialized-arrays.direct.ulong
|
||||
specialized-arrays.direct.ulonglong
|
||||
specialized-arrays.direct.ushort ;
|
||||
IN: classes.c-types
|
||||
|
||||
PREDICATE: char < fixnum
|
||||
HEX: -80 HEX: 7f between? ;
|
||||
|
||||
PREDICATE: uchar < fixnum
|
||||
HEX: 0 HEX: ff between? ;
|
||||
|
||||
PREDICATE: short < fixnum
|
||||
HEX: -8000 HEX: 7fff between? ;
|
||||
|
||||
PREDICATE: ushort < fixnum
|
||||
HEX: 0 HEX: ffff between? ;
|
||||
|
||||
PREDICATE: int < integer
|
||||
HEX: -8000,0000 HEX: 7fff,ffff between? ;
|
||||
|
||||
PREDICATE: uint < integer
|
||||
HEX: 0 HEX: ffff,ffff between? ;
|
||||
|
||||
PREDICATE: longlong < integer
|
||||
HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
|
||||
|
||||
PREDICATE: ulonglong < integer
|
||||
HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
|
||||
|
||||
UNION: single-float float ;
|
||||
UNION: single-complex complex ;
|
||||
|
||||
SYMBOLS: long ulong long-bits ;
|
||||
|
||||
<<
|
||||
"long" heap-size 8 =
|
||||
[
|
||||
\ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
|
||||
\ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
|
||||
64 \ long-bits set-global
|
||||
] [
|
||||
\ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
|
||||
\ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class
|
||||
32 \ long-bits set-global
|
||||
] if
|
||||
>>
|
||||
|
||||
: set-class-c-type ( class initial c-type <direct-array> -- )
|
||||
[ "initial-value" set-word-prop ]
|
||||
[ c-type "class-c-type" set-word-prop ]
|
||||
[ "class-direct-array" set-word-prop ] tri-curry* tri ;
|
||||
|
||||
: class-c-type ( class -- c-type )
|
||||
"class-c-type" word-prop ;
|
||||
: class-direct-array ( class -- <direct-array> )
|
||||
"class-direct-array" word-prop ;
|
||||
|
||||
\ f f "void*" \ <direct-void*-array> set-class-c-type
|
||||
pinned-c-ptr f "void*" \ <direct-void*-array> set-class-c-type
|
||||
boolean f "bool" \ <direct-bool-array> set-class-c-type
|
||||
char 0 "char" \ <direct-char-array> set-class-c-type
|
||||
uchar 0 "uchar" \ <direct-uchar-array> set-class-c-type
|
||||
short 0 "short" \ <direct-short-array> set-class-c-type
|
||||
ushort 0 "ushort" \ <direct-ushort-array> set-class-c-type
|
||||
int 0 "int" \ <direct-int-array> set-class-c-type
|
||||
uint 0 "uint" \ <direct-uint-array> set-class-c-type
|
||||
long 0 "long" \ <direct-long-array> set-class-c-type
|
||||
ulong 0 "ulong" \ <direct-ulong-array> set-class-c-type
|
||||
longlong 0 "longlong" \ <direct-longlong-array> set-class-c-type
|
||||
ulonglong 0 "ulonglong" \ <direct-ulonglong-array> set-class-c-type
|
||||
float 0.0 "double" \ <direct-double-array> set-class-c-type
|
||||
single-float 0.0 "float" \ <direct-float-array> set-class-c-type
|
||||
complex C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
|
||||
single-complex C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-array> set-class-c-type
|
||||
|
||||
char [ 8 bits 8 >signed ] "coercer" set-word-prop
|
||||
uchar [ 8 bits ] "coercer" set-word-prop
|
||||
short [ 16 bits 16 >signed ] "coercer" set-word-prop
|
||||
ushort [ 16 bits ] "coercer" set-word-prop
|
||||
int [ 32 bits 32 >signed ] "coercer" set-word-prop
|
||||
uint [ 32 bits ] "coercer" set-word-prop
|
||||
long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
|
||||
ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop
|
||||
longlong [ 64 bits 64 >signed ] "coercer" set-word-prop
|
||||
ulonglong [ 64 bits ] "coercer" set-word-prop
|
||||
|
||||
PREDICATE: c-type-class < class
|
||||
"class-c-type" word-prop ;
|
||||
|
||||
GENERIC: direct-array-of ( alien len class -- array ) inline
|
||||
|
||||
M: c-type-class direct-array-of
|
||||
class-direct-array execute( alien len -- array ) ; inline
|
||||
|
||||
M: c-type-class c-type class-c-type ;
|
||||
M: c-type-class c-type-align class-c-type c-type-align ;
|
||||
M: c-type-class c-type-getter class-c-type c-type-getter ;
|
||||
M: c-type-class c-type-setter class-c-type c-type-setter ;
|
||||
M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
|
||||
M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
|
||||
M: c-type-class heap-size class-c-type heap-size ;
|
||||
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors assocs classes classes.struct kernel math
|
||||
prettyprint.backend prettyprint.custom prettyprint.sections
|
||||
see.private sequences words ;
|
||||
IN: classes.struct.prettyprint
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: struct-definer-word ( class -- word )
|
||||
struct-slots dup length 2 >=
|
||||
[ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
|
||||
[ drop \ STRUCT: ] if ;
|
||||
|
||||
: struct>assoc ( struct -- assoc )
|
||||
[ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: struct-class see-class*
|
||||
<colon dup struct-definer-word pprint-word dup pprint-word
|
||||
<block struct-slots [ pprint-slot ] each
|
||||
block> pprint-; block> ;
|
||||
|
||||
M: struct pprint-delims
|
||||
drop \ S{ \ } ;
|
||||
|
||||
M: struct >pprint-sequence
|
||||
[ class ] [ struct-slot-values ] bi class-slot-sequence ;
|
||||
|
||||
M: struct pprint*
|
||||
[ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: alien classes help.markup help.syntax kernel libc
|
||||
quotations slots ;
|
||||
IN: classes.struct
|
||||
|
||||
HELP: <struct-boa>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
}
|
||||
{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
|
||||
|
||||
HELP: <struct>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "struct" struct }
|
||||
}
|
||||
{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
|
||||
|
||||
{ <struct> <struct-boa> malloc-struct memory>struct } related-words
|
||||
|
||||
HELP: STRUCT:
|
||||
{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
|
||||
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
|
||||
{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
|
||||
{ $list
|
||||
{ "Struct classes cannot have a superclass defined." }
|
||||
{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." }
|
||||
{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
|
||||
} } ;
|
||||
|
||||
HELP: S{
|
||||
{ $syntax "S{ class slots... }" }
|
||||
{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
|
||||
{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
|
||||
|
||||
HELP: UNION-STRUCT:
|
||||
{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
|
||||
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
|
||||
{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
|
||||
|
||||
HELP: define-struct-class
|
||||
{ $values
|
||||
{ "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
|
||||
}
|
||||
{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
|
||||
|
||||
HELP: define-union-struct-class
|
||||
{ $values
|
||||
{ "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
|
||||
}
|
||||
{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
|
||||
|
||||
HELP: malloc-struct
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "struct" struct }
|
||||
}
|
||||
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
|
||||
|
||||
HELP: memory>struct
|
||||
{ $values
|
||||
{ "ptr" c-ptr } { "class" class }
|
||||
{ "struct" struct }
|
||||
}
|
||||
{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
|
||||
|
||||
HELP: struct
|
||||
{ $class-description "The parent class of all struct types." } ;
|
||||
|
||||
{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
|
||||
|
||||
HELP: struct-class
|
||||
{ $class-description "The metaclass of all " { $link struct } " classes." } ;
|
||||
|
||||
ARTICLE: "classes.struct" "Struct classes"
|
||||
{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
|
||||
{ $subsection POSTPONE: STRUCT: }
|
||||
"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
|
||||
{ $subsection <struct> }
|
||||
{ $subsection <struct-boa> }
|
||||
{ $subsection malloc-struct }
|
||||
{ $subsection memory>struct }
|
||||
"Structs have literal syntax like tuples:"
|
||||
{ $subsection POSTPONE: S{ }
|
||||
"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
|
||||
{ $subsection POSTPONE: UNION-STRUCT: }
|
||||
;
|
||||
|
||||
ABOUT: "classes.struct"
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.structs.fields classes.c-types
|
||||
classes.struct combinators io.streams.string kernel libc literals math
|
||||
multiline namespaces prettyprint prettyprint.config see tools.test ;
|
||||
IN: classes.struct.tests
|
||||
|
||||
STRUCT: struct-test-foo
|
||||
{ x char }
|
||||
{ y int initial: 123 }
|
||||
{ z boolean } ;
|
||||
|
||||
STRUCT: struct-test-bar
|
||||
{ w ushort initial: HEX: ffff }
|
||||
{ foo struct-test-foo } ;
|
||||
|
||||
[ 12 ] [ struct-test-foo heap-size ] unit-test
|
||||
[ 16 ] [ struct-test-bar heap-size ] unit-test
|
||||
[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
|
||||
[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
|
||||
|
||||
[ 1 2 3 t ] [
|
||||
1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
|
||||
{
|
||||
[ w>> ]
|
||||
[ foo>> x>> ]
|
||||
[ foo>> y>> ]
|
||||
[ foo>> z>> ]
|
||||
} cleave
|
||||
] unit-test
|
||||
|
||||
[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
|
||||
[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
|
||||
|
||||
UNION-STRUCT: struct-test-float-and-bits
|
||||
{ f single-float }
|
||||
{ bits uint } ;
|
||||
|
||||
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
|
||||
[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
|
||||
|
||||
[ ] [ struct-test-foo malloc-struct free ] unit-test
|
||||
|
||||
[ "S{ struct-test-foo { y 7654 } }" ]
|
||||
[
|
||||
f boa-tuples?
|
||||
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
|
||||
with-variable
|
||||
] unit-test
|
||||
|
||||
[ "S{ struct-test-foo f 0 7654 f }" ]
|
||||
[
|
||||
t boa-tuples?
|
||||
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
|
||||
with-variable
|
||||
] unit-test
|
||||
|
||||
[ <" USING: classes.c-types classes.struct kernel ;
|
||||
IN: classes.struct.tests
|
||||
STRUCT: struct-test-foo
|
||||
{ x char initial: 0 } { y int initial: 123 }
|
||||
{ z boolean initial: f } ;
|
||||
"> ]
|
||||
[ [ struct-test-foo see ] with-string-writer ] unit-test
|
||||
|
||||
[ <" USING: classes.c-types classes.struct ;
|
||||
IN: classes.struct.tests
|
||||
UNION-STRUCT: struct-test-float-and-bits
|
||||
{ f single-float initial: 0.0 } { bits uint initial: 0 } ;
|
||||
"> ]
|
||||
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
|
||||
|
||||
[ {
|
||||
T{ field-spec
|
||||
{ name "x" }
|
||||
{ offset 0 }
|
||||
{ type $[ char c-type ] }
|
||||
{ reader x>> }
|
||||
{ writer (>>x) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "y" }
|
||||
{ offset 4 }
|
||||
{ type $[ int c-type ] }
|
||||
{ reader y>> }
|
||||
{ writer (>>y) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "z" }
|
||||
{ offset 8 }
|
||||
{ type $[ boolean c-type ] }
|
||||
{ reader z>> }
|
||||
{ writer (>>z) }
|
||||
}
|
||||
} ] [ "struct-test-foo" c-type fields>> ] unit-test
|
||||
|
||||
[ {
|
||||
T{ field-spec
|
||||
{ name "f" }
|
||||
{ offset 0 }
|
||||
{ type $[ single-float c-type ] }
|
||||
{ reader f>> }
|
||||
{ writer (>>f) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "bits" }
|
||||
{ offset 0 }
|
||||
{ type $[ uint c-type ] }
|
||||
{ reader bits>> }
|
||||
{ writer (>>bits) }
|
||||
}
|
||||
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,213 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
|
||||
byte-arrays classes classes.c-types classes.parser classes.tuple
|
||||
classes.tuple.parser classes.tuple.private combinators
|
||||
combinators.smart fry generalizations generic.parser kernel
|
||||
kernel.private libc macros make math math.order parser
|
||||
quotations sequences slots slots.private struct-arrays words ;
|
||||
FROM: slots => reader-word writer-word ;
|
||||
IN: classes.struct
|
||||
|
||||
! struct class
|
||||
|
||||
TUPLE: struct
|
||||
{ (underlying) c-ptr read-only } ;
|
||||
|
||||
PREDICATE: struct-class < tuple-class
|
||||
\ struct subclass-of? ;
|
||||
|
||||
: struct-slots ( struct -- slots )
|
||||
"struct-slots" word-prop ;
|
||||
|
||||
! struct allocation
|
||||
|
||||
M: struct >c-ptr
|
||||
2 slot { c-ptr } declare ; inline
|
||||
|
||||
: memory>struct ( ptr class -- struct )
|
||||
over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
|
||||
tuple-layout <tuple> [ 2 set-slot ] keep ;
|
||||
|
||||
: malloc-struct ( class -- struct )
|
||||
[ heap-size malloc ] keep memory>struct ; inline
|
||||
|
||||
: (struct) ( class -- struct )
|
||||
[ heap-size <byte-array> ] keep memory>struct ; inline
|
||||
|
||||
: <struct> ( class -- struct )
|
||||
dup "prototype" word-prop
|
||||
[ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
|
||||
|
||||
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
||||
[
|
||||
[ <wrapper> \ (struct) [ ] 2sequence ]
|
||||
[
|
||||
struct-slots
|
||||
[ length \ ndip ]
|
||||
[ [ name>> setter-word 1quotation ] map \ spread ] bi
|
||||
] bi
|
||||
] [ ] output>sequence ;
|
||||
|
||||
: pad-struct-slots ( values class -- values' class )
|
||||
[ struct-slots [ initial>> ] map over length tail append ] keep ;
|
||||
|
||||
: (reader-quot) ( slot -- quot )
|
||||
[ class>> c-type-getter-boxer ]
|
||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||
|
||||
: (writer-quot) ( slot -- quot )
|
||||
[ class>> c-setter ]
|
||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||
|
||||
: (boxer-quot) ( class -- quot )
|
||||
'[ _ memory>struct ] ;
|
||||
|
||||
: (unboxer-quot) ( class -- quot )
|
||||
drop [ >c-ptr ] ;
|
||||
|
||||
M: struct-class boa>object
|
||||
swap pad-struct-slots
|
||||
[ (struct) ] [ struct-slots ] bi
|
||||
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
|
||||
|
||||
! Struct slot accessors
|
||||
|
||||
GENERIC: struct-slot-values ( struct -- sequence )
|
||||
|
||||
M: struct-class reader-quot
|
||||
nip (reader-quot) ;
|
||||
|
||||
M: struct-class writer-quot
|
||||
nip (writer-quot) ;
|
||||
|
||||
: struct-slot-values-quot ( class -- quot )
|
||||
struct-slots
|
||||
[ name>> reader-word 1quotation ] map
|
||||
\ cleave [ ] 2sequence
|
||||
\ output>array [ ] 2sequence ;
|
||||
|
||||
: (define-struct-slot-values-method) ( class -- )
|
||||
[ \ struct-slot-values create-method-in ]
|
||||
[ struct-slot-values-quot ] bi define ;
|
||||
|
||||
! Struct as c-type
|
||||
|
||||
: slot>field ( slot -- field )
|
||||
field-spec new swap {
|
||||
[ name>> >>name ]
|
||||
[ offset>> >>offset ]
|
||||
[ class>> c-type >>type ]
|
||||
[ name>> reader-word >>reader ]
|
||||
[ name>> writer-word >>writer ]
|
||||
} cleave ;
|
||||
|
||||
: define-struct-for-class ( class -- )
|
||||
[
|
||||
{
|
||||
[ name>> ]
|
||||
[ "struct-size" word-prop ]
|
||||
[ "struct-align" word-prop ]
|
||||
[ struct-slots [ slot>field ] map ]
|
||||
} cleave
|
||||
(define-struct)
|
||||
] [
|
||||
[ name>> c-type ]
|
||||
[ (unboxer-quot) >>unboxer-quot ]
|
||||
[ (boxer-quot) >>boxer-quot ] tri drop
|
||||
] bi ;
|
||||
|
||||
: align-offset ( offset class -- offset' )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( slots -- size )
|
||||
0 [
|
||||
[ class>> align-offset ] keep
|
||||
[ (>>offset) ] [ class>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
|
||||
: union-struct-offsets ( slots -- size )
|
||||
[ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
|
||||
|
||||
: struct-align ( slots -- align )
|
||||
[ class>> c-type-align ] [ max ] map-reduce ;
|
||||
|
||||
M: struct-class c-type
|
||||
name>> c-type ;
|
||||
|
||||
M: struct-class c-type-align
|
||||
"struct-align" word-prop ;
|
||||
|
||||
M: struct-class c-type-getter
|
||||
drop [ swap <displaced-alien> ] ;
|
||||
|
||||
M: struct-class c-type-setter
|
||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
||||
M: struct-class c-type-boxer-quot
|
||||
(boxer-quot) ;
|
||||
|
||||
M: struct-class c-type-unboxer-quot
|
||||
(unboxer-quot) ;
|
||||
|
||||
M: struct-class heap-size
|
||||
"struct-size" word-prop ;
|
||||
|
||||
M: struct-class direct-array-of
|
||||
<direct-struct-array> ;
|
||||
|
||||
! class definition
|
||||
|
||||
: struct-prototype ( class -- prototype )
|
||||
[ heap-size <byte-array> ]
|
||||
[ memory>struct ]
|
||||
[ struct-slots ] tri
|
||||
[
|
||||
[ initial>> ]
|
||||
[ (writer-quot) ] bi
|
||||
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
|
||||
] each ;
|
||||
|
||||
: (struct-word-props) ( class slots size align -- )
|
||||
[
|
||||
[ "struct-slots" set-word-prop ]
|
||||
[ define-accessors ] 2bi
|
||||
]
|
||||
[ "struct-size" set-word-prop ]
|
||||
[ "struct-align" set-word-prop ] tri-curry*
|
||||
[ tri ] 3curry
|
||||
[ dup struct-prototype "prototype" set-word-prop ]
|
||||
[ (define-struct-slot-values-method) ] tri ;
|
||||
|
||||
: check-struct-slots ( slots -- )
|
||||
[ class>> c-type drop ] each ;
|
||||
|
||||
: (define-struct-class) ( class slots offsets-quot -- )
|
||||
[ drop struct f define-tuple-class ]
|
||||
swap '[
|
||||
make-slots dup
|
||||
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
|
||||
(struct-word-props)
|
||||
]
|
||||
[ drop define-struct-for-class ] 2tri ; inline
|
||||
|
||||
: define-struct-class ( class slots -- )
|
||||
[ struct-offsets ] (define-struct-class) ;
|
||||
|
||||
: define-union-struct-class ( class slots -- )
|
||||
[ union-struct-offsets ] (define-struct-class) ;
|
||||
|
||||
: parse-struct-definition ( -- class slots )
|
||||
CREATE-CLASS [ parse-tuple-slots ] { } make ;
|
||||
|
||||
SYNTAX: STRUCT:
|
||||
parse-struct-definition define-struct-class ;
|
||||
SYNTAX: UNION-STRUCT:
|
||||
parse-struct-definition define-union-struct-class ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
|
||||
|
||||
SYNTAX: S{
|
||||
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: alien destructors help.markup help.syntax kernel math ;
|
||||
IN: memory.piles
|
||||
|
||||
HELP: <pile>
|
||||
{ $values
|
||||
{ "size" integer }
|
||||
{ "pile" pile }
|
||||
}
|
||||
{ $description "Allocates " { $snippet "size" } " bytes of raw memory for a new " { $link pile } ". The pile should be " { $link dispose } "d when it is no longer needed." } ;
|
||||
|
||||
HELP: not-enough-pile-space
|
||||
{ $values
|
||||
{ "pile" pile }
|
||||
}
|
||||
{ $description "This error is thrown by " { $link pile-alloc } " when the " { $link pile } " does not have enough remaining space for the requested allocation." } ;
|
||||
|
||||
HELP: pile
|
||||
{ $class-description "A " { $snippet "pile" } " is a block of raw memory that can be apportioned out in constant time. A pile is allocated using the " { $link <pile> } " word. Blocks of memory can be requested from the pile using " { $link pile-alloc } ", and all the pile's memory can be reclaimed with " { $link pile-empty } "." } ;
|
||||
|
||||
HELP: pile-align
|
||||
{ $values
|
||||
{ "pile" pile } { "align" "a power of two" }
|
||||
{ "pile" pile }
|
||||
}
|
||||
{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ;
|
||||
|
||||
HELP: pile-alloc
|
||||
{ $values
|
||||
{ "pile" pile } { "size" integer }
|
||||
{ "alien" alien }
|
||||
}
|
||||
{ $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
|
||||
|
||||
HELP: pile-empty
|
||||
{ $values
|
||||
{ "pile" pile }
|
||||
}
|
||||
{ $description "Reclaims all the memory allocated out of a " { $link pile } ". Allocations will resume from the beginning of the pile." } ;
|
||||
|
||||
ARTICLE: "memory.piles" "Piles"
|
||||
"A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning."
|
||||
{ $subsection <pile> }
|
||||
{ $subsection pile-alloc }
|
||||
{ $subsection pile-align }
|
||||
{ $subsection pile-empty }
|
||||
"An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ;
|
||||
|
||||
ABOUT: "memory.piles"
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien destructors kernel math
|
||||
memory.piles tools.test ;
|
||||
IN: memory.piles.tests
|
||||
|
||||
[ 25 ] [
|
||||
[
|
||||
100 <pile> &dispose
|
||||
[ 25 pile-alloc ] [ 50 pile-alloc ] bi
|
||||
swap [ alien-address ] bi@ -
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ 32 ] [
|
||||
[
|
||||
100 <pile> &dispose
|
||||
[ 25 pile-alloc ] [ 8 pile-align 50 pile-alloc ] bi
|
||||
swap [ alien-address ] bi@ -
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ 75 ] [
|
||||
[
|
||||
100 <pile> &dispose
|
||||
dup 25 pile-alloc drop
|
||||
dup 50 pile-alloc drop
|
||||
offset>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ 100 ] [
|
||||
[
|
||||
100 <pile> &dispose
|
||||
dup 25 pile-alloc drop
|
||||
dup 75 pile-alloc drop
|
||||
offset>>
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
100 <pile> &dispose
|
||||
dup 25 pile-alloc drop
|
||||
dup 76 pile-alloc drop
|
||||
] with-destructors
|
||||
] [ not-enough-pile-space? ] must-fail-with
|
||||
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien destructors kernel libc math ;
|
||||
IN: memory.piles
|
||||
|
||||
TUPLE: pile
|
||||
{ underlying c-ptr }
|
||||
{ size integer }
|
||||
{ offset integer } ;
|
||||
|
||||
ERROR: not-enough-pile-space pile ;
|
||||
|
||||
M: pile dispose
|
||||
[ [ free ] when* f ] change-underlying drop ;
|
||||
|
||||
: <pile> ( size -- pile )
|
||||
[ malloc ] keep 0 pile boa ;
|
||||
|
||||
: pile-empty ( pile -- )
|
||||
0 >>offset drop ;
|
||||
|
||||
: pile-alloc ( pile size -- alien )
|
||||
[
|
||||
[ [ ] [ size>> ] [ offset>> ] tri ] dip +
|
||||
< [ not-enough-pile-space ] [ drop ] if
|
||||
] [
|
||||
drop [ offset>> ] [ underlying>> ] bi <displaced-alien>
|
||||
] [
|
||||
[ + ] curry change-offset drop
|
||||
] 2tri ;
|
||||
|
||||
: pile-align ( pile align -- pile )
|
||||
[ align ] curry change-offset ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Preallocated raw memory blocks
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: classes help.markup help.syntax kernel math ;
|
||||
IN: memory.pools
|
||||
|
||||
HELP: <pool>
|
||||
{ $values
|
||||
{ "size" integer } { "class" class }
|
||||
{ "pool" pool }
|
||||
}
|
||||
{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } "." } ;
|
||||
|
||||
HELP: POOL:
|
||||
{ $syntax "POOL: class size" }
|
||||
{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } ", and associates it with the class using " { $link set-class-pool } "." } ;
|
||||
|
||||
HELP: class-pool
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "pool" pool }
|
||||
}
|
||||
{ $description "Returns the " { $link pool } " associated with " { $snippet "class" } ", or " { $link f } " if no pool is associated." } ;
|
||||
|
||||
HELP: free-to-pool
|
||||
{ $values
|
||||
{ "object" object }
|
||||
}
|
||||
{ $description "Frees an object from the " { $link pool } " it was allocated from. The object must have been allocated by " { $link new-from-pool } "." } ;
|
||||
|
||||
HELP: new-from-pool
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object }
|
||||
}
|
||||
{ $description "Allocates an object from the " { $link pool } " associated with " { $snippet "class" } ". If the pool is exhausted, " { $link f } " is returned." } ;
|
||||
|
||||
{ POSTPONE: POOL: class-pool set-class-pool new-from-pool free-to-pool } related-words
|
||||
|
||||
HELP: pool
|
||||
{ $class-description "A " { $snippet "pool" } " contains a fixed-size set of preallocated tuple objects. Once the pool has been allocated, its objects can be allocated with " { $link pool-new } " and freed with " { $link pool-free } " in constant time. A pool can also be associated with its class with the " { $link POSTPONE: POOL: } " syntax or the " { $link set-class-pool } " word, after which the words " { $link new-from-pool } " and " { $link free-to-pool } " can be used with the class name to allocate and free objects." } ;
|
||||
|
||||
HELP: pool-free
|
||||
{ $values
|
||||
{ "object" object } { "pool" pool }
|
||||
}
|
||||
{ $description "Frees an object back into " { $link pool } "." } ;
|
||||
|
||||
HELP: pool-size
|
||||
{ $values
|
||||
{ "pool" pool }
|
||||
{ "size" integer }
|
||||
}
|
||||
{ $description "Returns the number of unallocated objects inside a " { $link pool } "." } ;
|
||||
|
||||
HELP: pool-new
|
||||
{ $values
|
||||
{ "pool" pool }
|
||||
{ "object" object }
|
||||
}
|
||||
{ $description "Returns an unallocated object out of a " { $link pool } ". If the pool is exhausted, " { $link f } " is returned." } ;
|
||||
|
||||
{ pool <pool> pool-new pool-free pool-size } related-words
|
||||
|
||||
HELP: set-class-pool
|
||||
{ $values
|
||||
{ "class" class } { "pool" pool }
|
||||
}
|
||||
{ $description "Associates a " { $link pool } " with " { $snippet "class" } "." } ;
|
||||
|
||||
ARTICLE: "memory.pools" "Pools"
|
||||
"The " { $vocab-link "memory.pools" } " vocabulary provides " { $link pool } " objects which manage preallocated collections of objects."
|
||||
{ $subsection pool }
|
||||
{ $subsection POSTPONE: POOL: }
|
||||
{ $subsection new-from-pool }
|
||||
{ $subsection free-to-pool } ;
|
||||
|
||||
ABOUT: "memory.pools"
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: kernel memory.pools tools.test ;
|
||||
IN: memory.pools.tests
|
||||
|
||||
TUPLE: foo x ;
|
||||
|
||||
[ 1 ] [
|
||||
foo 2 foo <pool> set-class-pool
|
||||
|
||||
foo new-from-pool drop
|
||||
foo class-pool pool-size
|
||||
] unit-test
|
||||
|
||||
[ T{ foo } T{ foo } f ] [
|
||||
foo 2 foo <pool> set-class-pool
|
||||
|
||||
foo new-from-pool
|
||||
foo new-from-pool
|
||||
foo new-from-pool
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
foo 2 foo <pool> set-class-pool
|
||||
|
||||
foo new-from-pool
|
||||
foo new-from-pool
|
||||
eq?
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays bit-arrays classes
|
||||
classes.tuple.private fry kernel locals parser
|
||||
sequences sequences.private vectors words ;
|
||||
IN: memory.pools
|
||||
|
||||
TUPLE: pool
|
||||
prototype
|
||||
{ objects vector } ;
|
||||
|
||||
: <pool> ( size class -- pool )
|
||||
[ nip new ]
|
||||
[ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
|
||||
pool boa ;
|
||||
|
||||
: pool-size ( pool -- size )
|
||||
objects>> length ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: copy-tuple ( from to -- to )
|
||||
from tuple-size :> size
|
||||
size [| n | n from array-nth n to set-array-nth ] each
|
||||
to ; inline
|
||||
|
||||
: (pool-new) ( pool -- object )
|
||||
objects>> [ f ] [ pop ] if-empty ;
|
||||
|
||||
: (pool-init) ( pool object -- object )
|
||||
[ prototype>> ] dip copy-tuple ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: pool-new ( pool -- object )
|
||||
dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline
|
||||
|
||||
: pool-free ( object pool -- )
|
||||
objects>> push ;
|
||||
|
||||
: class-pool ( class -- pool )
|
||||
"pool" word-prop ;
|
||||
|
||||
: set-class-pool ( class pool -- )
|
||||
"pool" set-word-prop ;
|
||||
|
||||
: new-from-pool ( class -- object )
|
||||
class-pool pool-new ;
|
||||
|
||||
: free-to-pool ( object -- )
|
||||
dup class class-pool pool-free ;
|
||||
|
||||
SYNTAX: POOL:
|
||||
scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Preallocated pools of tuple objects
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: help help.markup help.syntax kernel quotations ;
|
||||
IN: prettyprint.callables
|
||||
|
||||
HELP: simplify-callable
|
||||
{ $values { "quot" callable } { "quot'" callable } }
|
||||
{ $description "Converts " { $snippet "quot" } " into an equivalent quotation by simplifying usages of " { $link dip } ", " { $link call } ", " { $link curry } ", and " { $link compose } " with literal parameters. This word is used when callable objects are prettyprinted." } ;
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! (c) 2009 Joe Groff bsd license
|
||||
USING: kernel math prettyprint prettyprint.callables
|
||||
tools.test ;
|
||||
IN: prettyprint.callables.tests
|
||||
|
||||
[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test
|
||||
[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test
|
||||
[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test
|
||||
[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test
|
||||
[ [ call ] ] [ [ call ] simplify-callable ] unit-test
|
||||
[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test
|
||||
[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test
|
||||
[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test
|
||||
[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test
|
||||
[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
! (c) 2009 Joe Groff bsd license
|
||||
USING: combinators combinators.short-circuit generalizations
|
||||
kernel macros math math.ranges prettyprint.custom quotations
|
||||
sequences words ;
|
||||
IN: prettyprint.callables
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: simple-combinators { dip call curry 2curry 3curry compose prepose }
|
||||
|
||||
: literal? ( obj -- ? ) word? not ;
|
||||
|
||||
MACRO: slice-match? ( quots -- quot: ( seq end -- ? ) )
|
||||
dup length
|
||||
[ 0 [a,b) [ [ - swap nth ] swap prefix prepend ] 2map ]
|
||||
[ nip \ nip swap \ >= [ ] 3sequence ] 2bi
|
||||
prefix \ 2&& [ ] 2sequence ;
|
||||
|
||||
: end-len>from-to ( seq end len -- from to seq )
|
||||
[ - ] [ drop 1 + ] 2bi rot ;
|
||||
|
||||
: slice-change ( seq end len quot -- seq' )
|
||||
[ end-len>from-to ] dip
|
||||
[ [ subseq ] dip call ] curry
|
||||
[ replace-slice ] 3bi ; inline
|
||||
|
||||
: when-slice-match ( seq i criteria quot -- seq' )
|
||||
[ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline
|
||||
|
||||
: simplify-dip ( quot i -- quot' )
|
||||
{ [ literal? ] [ callable? ] }
|
||||
[ 2 [ first2 swap suffix ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-call ( quot i -- quot' )
|
||||
{ [ callable? ] }
|
||||
[ 1 [ first ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-curry ( quot i -- quot' )
|
||||
{ [ literal? ] [ callable? ] }
|
||||
[ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-2curry ( quot i -- quot' )
|
||||
{ [ literal? ] [ literal? ] [ callable? ] }
|
||||
[ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-3curry ( quot i -- quot' )
|
||||
{ [ literal? ] [ literal? ] [ literal? ] [ callable? ] }
|
||||
[ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-compose ( quot i -- quot' )
|
||||
{ [ callable? ] [ callable? ] }
|
||||
[ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ;
|
||||
|
||||
: simplify-prepose ( quot i -- quot' )
|
||||
{ [ callable? ] [ callable? ] }
|
||||
[ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ;
|
||||
|
||||
: (simplify-callable) ( quot -- quot' )
|
||||
dup [ simple-combinators member? ] find {
|
||||
{ \ dip [ simplify-dip ] }
|
||||
{ \ call [ simplify-call ] }
|
||||
{ \ curry [ simplify-curry ] }
|
||||
{ \ 2curry [ simplify-2curry ] }
|
||||
{ \ 3curry [ simplify-3curry ] }
|
||||
{ \ compose [ simplify-compose ] }
|
||||
{ \ prepose [ simplify-prepose ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: simplify-callable ( quot -- quot' )
|
||||
[ (simplify-callable) ] to-fixed-point ;
|
||||
|
||||
M: callable >pprint-sequence simplify-callable ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Quotation simplification for prettyprinting automatically-constructed callable objects
|
||||
Loading…
Reference in New Issue