Merge branch 'master' of git://factorcode.org/git/factor
Samuel Tardieu
commit
b7c50e6159
|
|
@ -1,6 +1,6 @@
|
|||
IN: alarms.tests
|
||||
USING: alarms alarms.private kernel calendar sequences
|
||||
tools.test threads concurrency.count-downs ;
|
||||
IN: alarms.tests
|
||||
|
||||
[ ] [
|
||||
1 <count-down>
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays calendar combinators generic init
|
||||
kernel math namespaces sequences heaps boxes threads
|
||||
quotations assocs math.order ;
|
||||
USING: accessors assocs boxes calendar
|
||||
combinators.short-circuit fry heaps init kernel math.order
|
||||
namespaces quotations threads ;
|
||||
IN: alarms
|
||||
|
||||
TUPLE: alarm
|
||||
|
|
@ -21,21 +21,21 @@ SYMBOL: alarm-thread
|
|||
|
||||
ERROR: bad-alarm-frequency frequency ;
|
||||
: check-alarm ( frequency/f -- frequency/f )
|
||||
dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
|
||||
dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
|
||||
|
||||
: <alarm> ( quot time frequency -- alarm )
|
||||
check-alarm <box> alarm boa ;
|
||||
|
||||
: register-alarm ( alarm -- )
|
||||
dup dup time>> alarms get-global heap-push*
|
||||
swap entry>> >box
|
||||
[ dup time>> alarms get-global heap-push* ]
|
||||
[ entry>> >box ] bi
|
||||
notify-alarm-thread ;
|
||||
|
||||
: alarm-expired? ( alarm now -- ? )
|
||||
[ time>> ] dip before=? ;
|
||||
|
||||
: reschedule-alarm ( alarm -- )
|
||||
dup [ swap interval>> time+ now max ] change-time register-alarm ;
|
||||
dup '[ _ interval>> time+ now max ] change-time register-alarm ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
[ entry>> box> drop ]
|
||||
|
|
|
|||
|
|
@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
|
|||
ARTICLE: "c-arrays" "C arrays"
|
||||
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
||||
$nl
|
||||
"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
|
||||
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
|
||||
$nl
|
||||
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
|
||||
{ $subsection require-c-type-arrays }
|
||||
{ $subsection <c-type-array> }
|
||||
{ $subsection <c-type-direct-array> } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||
io.encodings.utf8 ;
|
||||
io.encodings.utf8 accessors ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -11,7 +11,12 @@ M: array c-type ;
|
|||
|
||||
M: array c-type-class drop object ;
|
||||
|
||||
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
|
||||
M: array c-type-boxed-class drop object ;
|
||||
|
||||
: array-length ( seq -- n )
|
||||
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
|
||||
|
||||
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
||||
|
|
@ -27,11 +32,15 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
M: array stack-size drop "void*" stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot drop [ ] ;
|
||||
M: array c-type-boxer-quot
|
||||
unclip
|
||||
[ array-length ]
|
||||
[ [ require-c-type-arrays ] keep ] bi*
|
||||
[ <c-type-direct-array> ] 2curry ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
M: value-type c-type-reg-class drop int-regs ;
|
||||
M: value-type c-type-rep drop int-rep ;
|
||||
|
||||
M: value-type c-type-getter
|
||||
drop [ swap <displaced-alien> ] ;
|
||||
|
|
@ -45,8 +54,9 @@ PREDICATE: string-type < pair
|
|||
|
||||
M: string-type c-type ;
|
||||
|
||||
M: string-type c-type-class
|
||||
drop object ;
|
||||
M: string-type c-type-class drop object ;
|
||||
|
||||
M: string-type c-type-boxed-class drop object ;
|
||||
|
||||
M: string-type heap-size
|
||||
drop "void*" heap-size ;
|
||||
|
|
@ -72,8 +82,8 @@ M: string-type box-return
|
|||
M: string-type stack-size
|
||||
drop "void*" stack-size ;
|
||||
|
||||
M: string-type c-type-reg-class
|
||||
drop int-regs ;
|
||||
M: string-type c-type-rep
|
||||
drop int-rep ;
|
||||
|
||||
M: string-type c-type-boxer
|
||||
drop "void*" c-type-boxer ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: alien.c-types
|
||||
USING: alien help.syntax help.markup libc kernel.private
|
||||
byte-arrays math strings hashtables alien.syntax alien.strings sequences
|
||||
io.encodings.string debugger destructors ;
|
||||
io.encodings.string debugger destructors vocabs.loader ;
|
||||
|
||||
HELP: <c-type>
|
||||
{ $values { "type" hashtable } }
|
||||
|
|
@ -128,6 +128,21 @@ HELP: malloc-string
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: require-c-type-arrays
|
||||
{ $values { "c-type" "a C type" } }
|
||||
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
|
||||
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
|
||||
|
||||
HELP: <c-type-array>
|
||||
{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
|
||||
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
|
||||
|
||||
HELP: <c-type-direct-array>
|
||||
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
|
||||
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
|
||||
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: alien.c-types.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc alien.strings io.encodings.utf8 ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||
[ 492 ] [ { "int" xyz } heap-size ] unit-test
|
||||
|
||||
[ -1 ] [ -1 <char> *char ] unit-test
|
||||
[ -1 ] [ -1 <short> *short ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
|
|||
cpu.architecture alien alien.accessors alien.strings quotations
|
||||
layouts system compiler.units io io.files io.encodings.binary
|
||||
io.streams.memory accessors combinators effects continuations fry
|
||||
classes ;
|
||||
classes vocabs vocabs.loader ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -13,17 +13,25 @@ DEFER: *char
|
|||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
TUPLE: abstract-c-type
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxed-class class initial: object }
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ reg-class initial: int-regs }
|
||||
size
|
||||
align
|
||||
array-class
|
||||
array-constructor
|
||||
direct-array-class
|
||||
direct-array-constructor
|
||||
sequence-mixin-class ;
|
||||
|
||||
TUPLE: c-type < abstract-c-type
|
||||
boxer
|
||||
unboxer
|
||||
{ rep initial: int-rep }
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
|
|
@ -68,12 +76,63 @@ M: string c-type ( name -- type )
|
|||
] ?if
|
||||
] if ;
|
||||
|
||||
: ?require-word ( word/pair -- )
|
||||
dup word? [ drop ] [ first require ] ?if ;
|
||||
|
||||
GENERIC: require-c-type-arrays ( c-type -- )
|
||||
|
||||
M: object require-c-type-arrays
|
||||
drop ;
|
||||
|
||||
M: c-type require-c-type-arrays
|
||||
[ array-class>> ?require-word ]
|
||||
[ sequence-mixin-class>> ?require-word ]
|
||||
[ direct-array-class>> ?require-word ] tri ;
|
||||
|
||||
M: string require-c-type-arrays
|
||||
c-type require-c-type-arrays ;
|
||||
|
||||
M: array require-c-type-arrays
|
||||
first c-type require-c-type-arrays ;
|
||||
|
||||
ERROR: specialized-array-vocab-not-loaded vocab word ;
|
||||
|
||||
: c-type-array-constructor ( c-type -- word )
|
||||
array-constructor>> dup array?
|
||||
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
|
||||
|
||||
: c-type-direct-array-constructor ( c-type -- word )
|
||||
direct-array-constructor>> dup array?
|
||||
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
|
||||
|
||||
GENERIC: <c-type-array> ( len c-type -- array )
|
||||
M: object <c-type-array>
|
||||
c-type-array-constructor execute( len -- array ) ; inline
|
||||
M: string <c-type-array>
|
||||
c-type <c-type-array> ; inline
|
||||
M: array <c-type-array>
|
||||
first c-type <c-type-array> ; inline
|
||||
|
||||
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
|
||||
M: object <c-type-direct-array>
|
||||
c-type-direct-array-constructor execute( alien len -- array ) ; inline
|
||||
M: string <c-type-direct-array>
|
||||
c-type <c-type-direct-array> ; inline
|
||||
M: array <c-type-direct-array>
|
||||
first c-type <c-type-direct-array> ; inline
|
||||
|
||||
GENERIC: c-type-class ( name -- class )
|
||||
|
||||
M: c-type c-type-class class>> ;
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
||||
M: string c-type-class c-type c-type-class ;
|
||||
|
||||
GENERIC: c-type-boxed-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-boxed-class boxed-class>> ;
|
||||
|
||||
M: string c-type-boxed-class c-type c-type-boxed-class ;
|
||||
|
||||
GENERIC: c-type-boxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-boxer boxer>> ;
|
||||
|
|
@ -82,7 +141,7 @@ M: string c-type-boxer c-type c-type-boxer ;
|
|||
|
||||
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||
|
||||
M: c-type c-type-boxer-quot boxer-quot>> ;
|
||||
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
|
||||
|
||||
|
|
@ -94,15 +153,15 @@ M: string c-type-unboxer c-type c-type-unboxer ;
|
|||
|
||||
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||
|
||||
M: c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
|
||||
|
||||
GENERIC: c-type-reg-class ( name -- reg-class )
|
||||
GENERIC: c-type-rep ( name -- rep )
|
||||
|
||||
M: c-type c-type-reg-class reg-class>> ;
|
||||
M: c-type c-type-rep rep>> ;
|
||||
|
||||
M: string c-type-reg-class c-type c-type-reg-class ;
|
||||
M: string c-type-rep c-type c-type-rep ;
|
||||
|
||||
GENERIC: c-type-getter ( name -- quot )
|
||||
|
||||
|
|
@ -118,7 +177,7 @@ M: string c-type-setter c-type c-type-setter ;
|
|||
|
||||
GENERIC: c-type-align ( name -- n )
|
||||
|
||||
M: c-type c-type-align align>> ;
|
||||
M: abstract-c-type c-type-align align>> ;
|
||||
|
||||
M: string c-type-align c-type c-type-align ;
|
||||
|
||||
|
|
@ -129,13 +188,11 @@ M: c-type c-type-stack-align? stack-align?>> ;
|
|||
M: string c-type-stack-align? c-type c-type-stack-align? ;
|
||||
|
||||
: c-type-box ( n type -- )
|
||||
dup c-type-reg-class
|
||||
swap c-type-boxer [ "No boxer" throw ] unless*
|
||||
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
|
||||
%box ;
|
||||
|
||||
: c-type-unbox ( n ctype -- )
|
||||
dup c-type-reg-class
|
||||
swap c-type-unboxer [ "No unboxer" throw ] unless*
|
||||
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
|
||||
%unbox ;
|
||||
|
||||
GENERIC: box-parameter ( n ctype -- )
|
||||
|
|
@ -169,7 +226,7 @@ GENERIC: heap-size ( type -- size ) foldable
|
|||
|
||||
M: string heap-size c-type heap-size ;
|
||||
|
||||
M: c-type heap-size size>> ;
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( type -- size ) foldable
|
||||
|
||||
|
|
@ -179,9 +236,9 @@ M: c-type stack-size size>> cell align ;
|
|||
|
||||
GENERIC: byte-length ( seq -- n ) flushable
|
||||
|
||||
M: byte-array byte-length length ;
|
||||
M: byte-array byte-length length ; inline
|
||||
|
||||
M: f byte-length drop 0 ;
|
||||
M: f byte-length drop 0 ; inline
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
c-type-getter [
|
||||
|
|
@ -224,7 +281,7 @@ M: memory-stream stream-read
|
|||
] [ [ + ] change-index drop ] 2bi ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup byte-length memcpy ;
|
||||
swap dup byte-length memcpy ; inline
|
||||
|
||||
: array-accessor ( type quot -- def )
|
||||
[
|
||||
|
|
@ -269,23 +326,42 @@ M: long-long-type box-return ( type -- )
|
|||
[ define-out ]
|
||||
tri ;
|
||||
|
||||
: expand-constants ( c-type -- c-type' )
|
||||
dup array? [
|
||||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
: ?lookup ( vocab word -- word/pair )
|
||||
over vocab [ swap lookup ] [ 2array ] if ;
|
||||
|
||||
: set-array-class* ( c-type vocab-stem type-stem -- c-type )
|
||||
{
|
||||
[
|
||||
[ "specialized-arrays." prepend ]
|
||||
[ "-array" append ] bi* ?lookup >>array-class
|
||||
]
|
||||
[
|
||||
[ "specialized-arrays." prepend ]
|
||||
[ "<" "-array>" surround ] bi* ?lookup >>array-constructor
|
||||
]
|
||||
[
|
||||
[ "specialized-arrays." prepend ]
|
||||
[ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
|
||||
]
|
||||
[
|
||||
[ "specialized-arrays.direct." prepend ]
|
||||
[ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
|
||||
]
|
||||
[
|
||||
[ "specialized-arrays.direct." prepend ]
|
||||
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
|
||||
]
|
||||
} 2cleave ;
|
||||
|
||||
: set-array-class ( c-type stem -- c-type )
|
||||
dup set-array-class* ;
|
||||
|
||||
CONSTANT: primitive-types
|
||||
{
|
||||
"char" "uchar"
|
||||
|
|
@ -300,6 +376,7 @@ CONSTANT: primitive-types
|
|||
[
|
||||
<c-type>
|
||||
c-ptr >>class
|
||||
c-ptr >>boxed-class
|
||||
[ alien-cell ] >>getter
|
||||
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
|
|
@ -307,106 +384,127 @@ CONSTANT: primitive-types
|
|||
[ >c-ptr ] >>unboxer-quot
|
||||
"box_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
"alien" "void*" set-array-class*
|
||||
"void*" define-primitive-type
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-8 ] >>getter
|
||||
[ set-alien-signed-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_signed_8" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
"longlong" set-array-class
|
||||
"longlong" define-primitive-type
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-8 ] >>getter
|
||||
[ set-alien-unsigned-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_unsigned_8" >>boxer
|
||||
"to_unsigned_8" >>unboxer
|
||||
"ulonglong" set-array-class
|
||||
"ulonglong" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-cell ] >>getter
|
||||
[ set-alien-signed-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_signed_cell" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"long" set-array-class
|
||||
"long" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-cell ] >>getter
|
||||
[ set-alien-unsigned-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"ulong" set-array-class
|
||||
"ulong" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-4 ] >>getter
|
||||
[ set-alien-signed-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_signed_4" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"int" set-array-class
|
||||
"int" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-4 ] >>getter
|
||||
[ set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_unsigned_4" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"uint" set-array-class
|
||||
"uint" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-signed-2 ] >>getter
|
||||
[ set-alien-signed-2 ] >>setter
|
||||
2 >>size
|
||||
2 >>align
|
||||
"box_signed_2" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"short" set-array-class
|
||||
"short" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-unsigned-2 ] >>getter
|
||||
[ set-alien-unsigned-2 ] >>setter
|
||||
2 >>size
|
||||
2 >>align
|
||||
"box_unsigned_2" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"ushort" set-array-class
|
||||
"ushort" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-signed-1 ] >>getter
|
||||
[ set-alien-signed-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_signed_1" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"char" set-array-class
|
||||
"char" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-unsigned-1 ] >>getter
|
||||
[ set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_unsigned_1" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"uchar" set-array-class
|
||||
"uchar" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
|
|
@ -416,33 +514,39 @@ CONSTANT: primitive-types
|
|||
1 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" set-array-class
|
||||
"bool" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
float >>class
|
||||
float >>boxed-class
|
||||
[ alien-float ] >>getter
|
||||
[ [ >float ] 2dip set-alien-float ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_float" >>boxer
|
||||
"to_float" >>unboxer
|
||||
single-float-regs >>reg-class
|
||||
single-float-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
"float" set-array-class
|
||||
"float" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
float >>class
|
||||
float >>boxed-class
|
||||
[ alien-double ] >>getter
|
||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_double" >>boxer
|
||||
"to_double" >>unboxer
|
||||
double-float-regs >>reg-class
|
||||
double-float-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
"double" set-array-class
|
||||
"double" define-primitive-type
|
||||
|
||||
"long" "ptrdiff_t" typedef
|
||||
"long" "intptr_t" typedef
|
||||
"ulong" "size_t" typedef
|
||||
] with-compilation-unit
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex kernel alien.c-types alien.syntax
|
||||
namespaces ;
|
||||
namespaces math ;
|
||||
IN: alien.complex.tests
|
||||
|
||||
C-STRUCT: complex-holder
|
||||
|
|
@ -16,3 +16,7 @@ C-STRUCT: complex-holder
|
|||
] unit-test
|
||||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
||||
|
||||
[ number ] [ "complex-float" c-type-boxed-class ] unit-test
|
||||
|
||||
[ number ] [ "complex-double" c-type-boxed-class ] unit-test
|
||||
|
|
@ -10,4 +10,4 @@ IN: alien.complex
|
|||
! This overrides the fact that small structures are never returned
|
||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
||||
"complex-float" c-type t >>return-in-registers? drop
|
||||
>>
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex.functor ;
|
||||
IN: alien.complex.functor.tests
|
||||
|
|
@ -30,6 +30,8 @@ define-struct
|
|||
T c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
number >>boxed-class
|
||||
T set-array-class
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.destructors ;
|
||||
IN: alien.destructors.tests
|
||||
|
|
@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words
|
|||
effects generalizations sequences ;
|
||||
IN: alien.destructors
|
||||
|
||||
SLOT: alien
|
||||
TUPLE: alien-destructor alien ;
|
||||
|
||||
FUNCTOR: define-destructor ( F -- )
|
||||
|
||||
|
|
@ -16,11 +16,12 @@ N [ F stack-effect out>> length ]
|
|||
|
||||
WHERE
|
||||
|
||||
TUPLE: F-destructor alien disposed ;
|
||||
TUPLE: F-destructor < alien-destructor ;
|
||||
|
||||
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
|
||||
: <F-destructor> ( alien -- destructor )
|
||||
F-destructor boa ; inline
|
||||
|
||||
M: F-destructor dispose* alien>> F N ndrop ;
|
||||
M: F-destructor dispose alien>> F N ndrop ;
|
||||
|
||||
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -357,15 +357,15 @@ M: character-type (<fortran-result>)
|
|||
|
||||
: (shuffle-map) ( return parameters -- ret par )
|
||||
[
|
||||
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
|
||||
fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
|
||||
letters swap head [ "ret" swap suffix ] map
|
||||
] [
|
||||
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
|
||||
[ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
|
||||
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
|
||||
] bi* ;
|
||||
|
||||
: (fortran-in-shuffle) ( ret par -- seq )
|
||||
[ [ second ] bi@ <=> ] sort append ;
|
||||
[ second ] sort-with append ;
|
||||
|
||||
: (fortran-out-shuffle) ( ret par -- seq )
|
||||
append ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: alien.libraries.tests
|
||||
USING: alien.libraries alien.syntax tools.test kernel ;
|
||||
IN: alien.libraries.tests
|
||||
|
||||
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
|
||||
|
||||
|
|
@ -7,4 +7,4 @@ USING: alien.libraries alien.syntax tools.test kernel ;
|
|||
|
||||
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
|
||||
|
||||
[ "fdasfsf" dll-valid? drop ] must-fail
|
||||
[ "fdasfsf" dll-valid? drop ] must-fail
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ IN: alien.structs.fields
|
|||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
[ "-" glue ] dip create ;
|
||||
[ "-" glue ] dip create dup make-deprecated ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
|
||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
|
||||
|
||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||
field-spec new
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>type
|
||||
swap >>type
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
|
|
|||
|
|
@ -30,4 +30,4 @@ ARTICLE: "c-unions" "C unions"
|
|||
{ $subsection POSTPONE: C-UNION: }
|
||||
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
|
||||
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: alien.structs.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc words vocabs namespaces layouts ;
|
||||
IN: alien.structs.tests
|
||||
|
||||
C-STRUCT: bar
|
||||
{ "int" "x" }
|
||||
|
|
|
|||
|
|
@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
|
|||
quotations byte-arrays ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type
|
||||
size
|
||||
align
|
||||
fields
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
return-in-registers? ;
|
||||
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
|
||||
|
||||
M: struct-type c-type ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
M: struct-type c-type-class drop byte-array ;
|
||||
|
||||
M: struct-type c-type-align align>> ;
|
||||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
|
||||
|
||||
|
|
@ -53,9 +35,10 @@ M: struct-type stack-size
|
|||
|
||||
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
||||
|
||||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type new
|
||||
: (define-struct) ( name size align fields class -- )
|
||||
[ [ align ] keep ] 2dip new
|
||||
byte-array >>class
|
||||
byte-array >>boxed-class
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
|
|
@ -71,14 +54,16 @@ M: struct-type stack-size
|
|||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
[ define-field ] each ;
|
||||
[ struct-type (define-struct) ] keep
|
||||
[ define-field ] each ; deprecated
|
||||
|
||||
: define-union ( name members -- )
|
||||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
compute-struct-align f struct-type (define-struct) ; deprecated
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
USE: vocabs.loader
|
||||
"struct-arrays" require
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: alien.syntax
|
||||
USING: alien alien.c-types alien.parser alien.structs
|
||||
help.markup help.syntax ;
|
||||
classes.struct help.markup help.syntax ;
|
||||
|
||||
HELP: DLL"
|
||||
{ $syntax "DLL\" path\"" }
|
||||
|
|
@ -55,12 +55,14 @@ HELP: TYPEDEF:
|
|||
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||
|
||||
HELP: C-STRUCT:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
|
||||
{ $syntax "C-STRUCT: name pairs... ;" }
|
||||
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
||||
{ $description "Defines a C struct layout and accessor words." }
|
||||
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
||||
|
||||
HELP: C-UNION:
|
||||
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
|
||||
{ $syntax "C-UNION: name members... ;" }
|
||||
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
||||
{ $description "Defines a new C type sized to fit its largest member." }
|
||||
|
|
|
|||
|
|
@ -22,17 +22,19 @@ SYNTAX: TYPEDEF:
|
|||
scan scan typedef ;
|
||||
|
||||
SYNTAX: C-STRUCT:
|
||||
scan current-vocab parse-definition define-struct ;
|
||||
scan current-vocab parse-definition define-struct ; deprecated
|
||||
|
||||
SYNTAX: C-UNION:
|
||||
scan parse-definition define-union ;
|
||||
scan parse-definition define-union ; deprecated
|
||||
|
||||
SYNTAX: C-ENUM:
|
||||
";" parse-tokens
|
||||
[ [ create-in ] dip define-constant ] each-index ;
|
||||
|
||||
ERROR: no-such-symbol name library ;
|
||||
|
||||
: address-of ( name library -- value )
|
||||
load-library dlsym [ "No such symbol" throw ] unless* ;
|
||||
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
|
||||
|
||||
SYNTAX: &:
|
||||
scan "c-library" get '[ _ _ address-of ] over push-all ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: ascii.tests
|
|||
|
||||
[ 4 ] [
|
||||
0 "There are Four Upper Case characters"
|
||||
[ LETTER? [ 1+ ] when ] each
|
||||
[ LETTER? [ 1 + ] when ] each
|
||||
] unit-test
|
||||
|
||||
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ SYMBOL: column
|
|||
: write1-lines ( ch -- )
|
||||
write1
|
||||
column get [
|
||||
1+ [ 76 = [ crlf ] when ]
|
||||
1 + [ 76 = [ crlf ] when ]
|
||||
[ 76 mod column set ] bi
|
||||
] when* ;
|
||||
|
||||
|
|
@ -48,7 +48,7 @@ SYMBOL: column
|
|||
|
||||
: encode-pad ( seq n -- )
|
||||
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
|
||||
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
|
||||
[ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
|
||||
|
||||
: decode4 ( seq -- )
|
||||
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: biassocs assocs namespaces tools.test hashtables kernel ;
|
||||
IN: biassocs.tests
|
||||
USING: biassocs assocs namespaces tools.test ;
|
||||
|
||||
<bihash> "h" set
|
||||
|
||||
|
|
@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set
|
|||
|
||||
[ "A" ] [ "a" "b" get at ] unit-test
|
||||
|
||||
[ "a" ] [ "A" "b" get value-at ] unit-test
|
||||
[ "a" ] [ "A" "b" get value-at ] unit-test
|
||||
|
||||
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
|
||||
|
||||
[ ] [ "h" get clone "g" set ] unit-test
|
||||
|
||||
[ ] [ 3 4 "g" get set-at ] unit-test
|
||||
|
||||
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test
|
||||
|
|
|
|||
|
|
@ -43,4 +43,7 @@ M: biassoc new-assoc
|
|||
INSTANCE: biassoc assoc
|
||||
|
||||
: >biassoc ( assoc -- biassoc )
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
|
||||
M: biassoc clone
|
||||
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: binary-search.tests
|
||||
USING: binary-search math.order vectors kernel tools.test ;
|
||||
IN: binary-search.tests
|
||||
|
||||
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
|
||||
|
|
@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
|
|||
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
|
||||
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
|
||||
|
||||
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
|
||||
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
|
||||
[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
|
|
|
|||
|
|
@ -44,33 +44,33 @@ PRIVATE>
|
|||
: <bit-array> ( n -- bit-array )
|
||||
dup bits>bytes <byte-array> bit-array boa ; inline
|
||||
|
||||
M: bit-array length length>> ;
|
||||
M: bit-array length length>> ; inline
|
||||
|
||||
M: bit-array nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
|
||||
|
||||
M: bit-array set-nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi*
|
||||
[ byte/bit set-bit ] 2keep
|
||||
swap n>byte set-alien-unsigned-1 ;
|
||||
swap n>byte set-alien-unsigned-1 ; inline
|
||||
|
||||
GENERIC: clear-bits ( bit-array -- )
|
||||
|
||||
M: bit-array clear-bits 0 (set-bits) ;
|
||||
M: bit-array clear-bits 0 (set-bits) ; inline
|
||||
|
||||
GENERIC: set-bits ( bit-array -- )
|
||||
|
||||
M: bit-array set-bits -1 (set-bits) ;
|
||||
M: bit-array set-bits -1 (set-bits) ; inline
|
||||
|
||||
M: bit-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
|
||||
|
||||
: >bit-array ( seq -- bit-array )
|
||||
T{ bit-array f 0 B{ } } clone-like ; inline
|
||||
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
|
||||
|
||||
M: bit-array new-sequence drop <bit-array> ;
|
||||
M: bit-array new-sequence drop <bit-array> ; inline
|
||||
|
||||
M: bit-array equal?
|
||||
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
|
||||
|
|
@ -81,9 +81,9 @@ M: bit-array resize
|
|||
resize-byte-array
|
||||
] 2bi
|
||||
bit-array boa
|
||||
dup clean-up ;
|
||||
dup clean-up ; inline
|
||||
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
M: bit-array byte-length length 7 + -3 shift ; inline
|
||||
|
||||
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
|
||||
|
||||
|
|
@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
|
|||
dup 0 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1+ <bit-array> 0 ] keep
|
||||
[ log2 1 + <bit-array> 0 ] keep
|
||||
[ dup 0 = ] [
|
||||
[ pick underlying>> pick set-alien-unsigned-1 ] keep
|
||||
[ 1+ ] [ -8 shift ] bi*
|
||||
[ 1 + ] [ -8 shift ] bi*
|
||||
] until 2drop
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: bit-sets.tests
|
||||
USING: bit-sets tools.test bit-arrays ;
|
||||
IN: bit-sets.tests
|
||||
|
||||
[ ?{ t f t f t f } ] [
|
||||
?{ t f f f t f }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: bit-vectors.tests
|
||||
USING: tools.test bit-vectors vectors sequences kernel math ;
|
||||
IN: bit-vectors.tests
|
||||
|
||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
|
|||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
|
||||
[ BIN: 1111111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
|
|||
[ get-abp + ] [ set-abp ] bi ; inline
|
||||
|
||||
: (align) ( n m -- n' )
|
||||
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
|
||||
[ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
|
||||
|
||||
: align ( n bitstream -- )
|
||||
[ get-abp swap (align) ] [ set-abp ] bi ; inline
|
||||
|
|
|
|||
|
|
@ -35,82 +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
|
||||
|
||||
{
|
||||
+ 1+ 1- 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
|
||||
} 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
|
||||
|
|
@ -1,38 +1,42 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
|
||||
compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
|
||||
compiler.cfg.stacks.finalize compiler.cfg.stacks.global
|
||||
compiler.codegen compiler.tree.builder compiler.tree.optimizer
|
||||
kernel make sequences tools.annotations tools.crossref ;
|
||||
USING: accessors kernel make sequences tools.annotations tools.crossref ;
|
||||
QUALIFIED: compiler.cfg.builder
|
||||
QUALIFIED: compiler.cfg.linear-scan
|
||||
QUALIFIED: compiler.cfg.mr
|
||||
QUALIFIED: compiler.cfg.optimizer
|
||||
QUALIFIED: compiler.cfg.stacks.finalize
|
||||
QUALIFIED: compiler.cfg.stacks.global
|
||||
QUALIFIED: compiler.codegen
|
||||
QUALIFIED: compiler.tree.builder
|
||||
QUALIFIED: compiler.tree.optimizer
|
||||
IN: bootstrap.compiler.timing
|
||||
|
||||
: passes ( word -- seq )
|
||||
def>> uses [ vocabulary>> "compiler." head? ] filter ;
|
||||
|
||||
: high-level-passes ( -- seq ) \ optimize-tree passes ;
|
||||
: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
|
||||
|
||||
: low-level-passes ( -- seq ) \ optimize-cfg passes ;
|
||||
: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
|
||||
|
||||
: machine-passes ( -- seq ) \ build-mr passes ;
|
||||
: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
|
||||
|
||||
: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
|
||||
: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
|
||||
|
||||
: all-passes ( -- seq )
|
||||
[
|
||||
\ build-tree ,
|
||||
\ optimize-tree ,
|
||||
\ compiler.tree.builder:build-tree ,
|
||||
\ compiler.tree.optimizer:optimize-tree ,
|
||||
high-level-passes %
|
||||
\ build-cfg ,
|
||||
\ compute-global-sets ,
|
||||
\ finalize-stack-shuffling ,
|
||||
\ optimize-cfg ,
|
||||
\ compiler.cfg.builder:build-cfg ,
|
||||
\ compiler.cfg.stacks.global:compute-global-sets ,
|
||||
\ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
|
||||
\ compiler.cfg.optimizer:optimize-cfg ,
|
||||
low-level-passes %
|
||||
\ compute-live-sets ,
|
||||
\ build-mr ,
|
||||
\ compiler.cfg.mr:build-mr ,
|
||||
machine-passes %
|
||||
linear-scan-passes %
|
||||
\ generate ,
|
||||
\ compiler.codegen:generate ,
|
||||
] { } make ;
|
||||
|
||||
all-passes [ [ reset ] [ add-timing ] bi ] each
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
IN: bootstrap.image.tests
|
||||
USING: bootstrap.image bootstrap.image.private tools.test
|
||||
kernel math ;
|
||||
IN: bootstrap.image.tests
|
||||
|
||||
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -234,7 +242,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
|
||||
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
|
||||
|
||||
: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
|
||||
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
|
||||
|
||||
: bignum>seq ( n -- seq )
|
||||
#! n is positive or zero.
|
||||
|
|
@ -244,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
|
||||
: emit-bignum ( n -- )
|
||||
dup dup 0 < [ neg ] when bignum>seq
|
||||
[ nip length 1+ emit-fixnum ]
|
||||
[ nip length 1 + emit-fixnum ]
|
||||
[ drop 0 < 1 0 ? emit ]
|
||||
[ nip emit-seq ]
|
||||
2tri ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ IN: bootstrap.image.upload
|
|||
SYMBOL: upload-images-destination
|
||||
|
||||
: destination ( -- dest )
|
||||
upload-images-destination get
|
||||
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
|
||||
or ;
|
||||
upload-images-destination get
|
||||
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
|
||||
or ;
|
||||
|
||||
: checksums ( -- temp ) "checksums.txt" temp-file ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ;
|
|||
|
||||
"math.ratios" require
|
||||
"math.floats" require
|
||||
"math.complex" require
|
||||
"math.complex" require
|
||||
|
|
|
|||
|
|
@ -8,12 +8,14 @@ IN: bootstrap.tools
|
|||
"tools.crossref"
|
||||
"tools.errors"
|
||||
"tools.deploy"
|
||||
"tools.destructors"
|
||||
"tools.disassembler"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.deprecation"
|
||||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: boxes.tests
|
||||
USING: boxes namespaces tools.test accessors ;
|
||||
IN: boxes.tests
|
||||
|
||||
[ ] [ <box> "b" set ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -8,4 +8,3 @@ SYNTAX: HEX{
|
|||
[ blank? not ] filter
|
||||
2 group [ hex> ] B{ } map-as
|
||||
parsed ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test cache ;
|
||||
IN: cache.tests
|
||||
|
|
@ -3,10 +3,10 @@
|
|||
USING: kernel assocs math accessors destructors fry sequences ;
|
||||
IN: cache
|
||||
|
||||
TUPLE: cache-assoc assoc max-age disposed ;
|
||||
TUPLE: cache-assoc < disposable assoc max-age ;
|
||||
|
||||
: <cache-assoc> ( -- cache )
|
||||
H{ } clone 10 f cache-assoc boa ;
|
||||
cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -38,6 +38,6 @@ PRIVATE>
|
|||
|
||||
: purge-cache ( cache -- )
|
||||
dup max-age>> '[
|
||||
[ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
|
||||
[ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
|
||||
[ values dispose-each ] dip
|
||||
] change-assoc drop ;
|
||||
] change-assoc drop ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: cairo.tests
|
||||
USING: cairo tools.test math.rectangles accessors ;
|
||||
IN: cairo.tests
|
||||
|
||||
[ { 10 20 } ] [
|
||||
{ 10 20 } [
|
||||
{ 0 1 } { 3 4 } <rect> fill-rect
|
||||
] make-bitmap-image dim>>
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -20,14 +20,14 @@ HELP: <date>
|
|||
{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
|
||||
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"2010 12 25 <date> >gmt midnight ."
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"2010 12 25 <date> instant >>gmt-offset ."
|
||||
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: month-names
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" object } }
|
||||
{ $description "Returns an array with the English names of all the months." }
|
||||
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,25 +34,25 @@ C: <timestamp> timestamp
|
|||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset-duration <timestamp> ;
|
||||
|
||||
ERROR: not-a-month n ;
|
||||
ERROR: not-a-month ;
|
||||
M: not-a-month summary
|
||||
drop "Months are indexed starting at 1" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: check-month ( n -- n )
|
||||
dup zero? [ not-a-month ] when ;
|
||||
[ not-a-month ] when-zero ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: month-names ( -- array )
|
||||
CONSTANT: month-names
|
||||
{
|
||||
"January" "February" "March" "April" "May" "June"
|
||||
"July" "August" "September" "October" "November" "December"
|
||||
} ;
|
||||
}
|
||||
|
||||
: month-name ( n -- string )
|
||||
check-month 1- month-names nth ;
|
||||
check-month 1 - month-names nth ;
|
||||
|
||||
CONSTANT: month-abbreviations
|
||||
{
|
||||
|
|
@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
|
|||
}
|
||||
|
||||
: month-abbreviation ( n -- string )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
check-month 1 - month-abbreviations nth ;
|
||||
|
||||
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
||||
|
||||
|
|
@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
|
|||
100 b * d + 4800 -
|
||||
m 10 /i + m 3 +
|
||||
12 m 10 /i * -
|
||||
e 153 m * 2 + 5 /i - 1+ ;
|
||||
e 153 m * 2 + 5 /i - 1 + ;
|
||||
|
||||
GENERIC: easter ( obj -- obj' )
|
||||
|
||||
|
|
@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
|
|||
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
|
||||
[ 3 >>month 1 >>day ] when ;
|
||||
|
||||
: unless-zero ( n quot -- )
|
||||
[ dup zero? [ drop ] ] dip if ; inline
|
||||
|
||||
M: integer +year ( timestamp n -- timestamp )
|
||||
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
|
||||
|
||||
|
|
@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
|
|||
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
|
||||
|
||||
: months/years ( n -- months years )
|
||||
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
|
||||
12 /rem [ 1 - 12 ] when-zero swap ; inline
|
||||
|
||||
M: integer +month ( timestamp n -- timestamp )
|
||||
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
|
||||
|
|
@ -371,10 +368,10 @@ M: duration time-
|
|||
#! http://web.textfiles.com/computers/formulas.txt
|
||||
#! good for any date since October 15, 1582
|
||||
[
|
||||
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
|
||||
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
|
||||
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
|
||||
[ 1+ 3 * 5 /i + ] keep 2 * +
|
||||
] dip 1+ + 7 mod ;
|
||||
[ 1 + 3 * 5 /i + ] keep 2 * +
|
||||
] dip 1 + + 7 mod ;
|
||||
|
||||
GENERIC: days-in-year ( obj -- n )
|
||||
|
||||
|
|
@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
|||
year leap-year? [
|
||||
year month day <date>
|
||||
year 3 1 <date>
|
||||
after=? [ 1+ ] when
|
||||
after=? [ 1 + ] when
|
||||
] when ;
|
||||
|
||||
: day-of-year ( timestamp -- n )
|
||||
|
|
|
|||
|
|
@ -68,8 +68,8 @@ M: array month. ( pair -- )
|
|||
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ day. ] keep
|
||||
1+ + 7 mod zero? [ nl ] [ bl ] if
|
||||
[ 1 + day. ] keep
|
||||
1 + + 7 mod zero? [ nl ] [ bl ] if
|
||||
] with each nl ;
|
||||
|
||||
M: timestamp month. ( timestamp -- )
|
||||
|
|
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
|
|||
GENERIC: year. ( obj -- )
|
||||
|
||||
M: integer year. ( n -- )
|
||||
12 [ 1+ 2array month. nl ] with each ;
|
||||
12 [ 1 + 2array month. nl ] with each ;
|
||||
|
||||
M: timestamp year. ( timestamp -- )
|
||||
year>> year. ;
|
||||
|
|
@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
|
|||
|
||||
: read-rfc3339-seconds ( s -- s' ch )
|
||||
"+-Z" read-until [
|
||||
[ string>number ] [ length 10 swap ^ ] bi / +
|
||||
[ string>number ] [ length 10^ ] bi / +
|
||||
] dip ;
|
||||
|
||||
: (rfc3339>timestamp) ( -- timestamp )
|
||||
|
|
@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
|
|||
"," read-token day-abbreviations3 member? check-timestamp drop
|
||||
read1 CHAR: \s assert=
|
||||
read-sp checked-number >>day
|
||||
read-sp month-abbreviations index 1+ check-timestamp >>month
|
||||
read-sp month-abbreviations index 1 + check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
|
@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
|
|||
"," read-token check-day-name
|
||||
read1 CHAR: \s assert=
|
||||
"-" read-token checked-number >>day
|
||||
"-" read-token month-abbreviations index 1+ check-timestamp >>month
|
||||
"-" read-token month-abbreviations index 1 + check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
|
@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
|
|||
: (cookie-string>timestamp-2) ( -- timestamp )
|
||||
timestamp new
|
||||
read-sp check-day-name
|
||||
read-sp month-abbreviations index 1+ check-timestamp >>month
|
||||
read-sp month-abbreviations index 1 + check-timestamp >>month
|
||||
read-sp checked-number >>day
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ locals sequences ;
|
|||
IN: channels.examples
|
||||
|
||||
: (counter) ( channel n -- )
|
||||
[ swap to ] 2keep 1+ (counter) ;
|
||||
[ swap to ] 2keep 1 + (counter) ;
|
||||
|
||||
: counter ( channel -- )
|
||||
2 (counter) ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Alaric Snell-Pym
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.fnv1
|
||||
|
||||
HELP: fnv1-32
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 32-bit." } ;
|
||||
|
||||
HELP: fnv1a-32
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 32-bit." } ;
|
||||
|
||||
|
||||
HELP: fnv1-64
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 64-bit." } ;
|
||||
|
||||
HELP: fnv1a-64
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 64-bit." } ;
|
||||
|
||||
|
||||
HELP: fnv1-128
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 128-bit." } ;
|
||||
|
||||
HELP: fnv1a-128
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 128-bit." } ;
|
||||
|
||||
|
||||
HELP: fnv1-256
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 256-bit." } ;
|
||||
|
||||
HELP: fnv1a-256
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 256-bit." } ;
|
||||
|
||||
|
||||
HELP: fnv1-512
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 512-bit." } ;
|
||||
|
||||
HELP: fnv1a-512
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 512-bit." } ;
|
||||
|
||||
|
||||
HELP: fnv1-1024
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 1024-bit." } ;
|
||||
|
||||
HELP: fnv1a-1024
|
||||
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
|
||||
|
||||
ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
|
||||
"The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
|
||||
|
||||
{ $subsection fnv1-32 }
|
||||
{ $subsection fnv1a-32 }
|
||||
|
||||
{ $subsection fnv1-64 }
|
||||
{ $subsection fnv1a-64 }
|
||||
|
||||
{ $subsection fnv1-128 }
|
||||
{ $subsection fnv1a-128 }
|
||||
|
||||
{ $subsection fnv1-256 }
|
||||
{ $subsection fnv1a-256 }
|
||||
|
||||
{ $subsection fnv1-512 }
|
||||
{ $subsection fnv1a-512 }
|
||||
|
||||
{ $subsection fnv1-1024 }
|
||||
{ $subsection fnv1a-1024 }
|
||||
;
|
||||
|
||||
ABOUT: "checksums.fnv1"
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
USING: checksums.fnv1 checksums strings tools.test ;
|
||||
IN: checksums.fnv1.tests
|
||||
|
||||
! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
|
||||
|
||||
[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
|
||||
[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
|
||||
[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
|
||||
[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
|
||||
|
||||
[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
|
||||
[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
|
||||
[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
|
||||
[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
|
||||
|
||||
[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
|
||||
[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
|
||||
[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
|
||||
[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
|
||||
|
||||
[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
|
||||
[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
|
||||
[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
|
||||
[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
|
||||
|
||||
! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
|
||||
! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.
|
||||
! So they may be right or wrong, but either way, them failing is cause for concern somewhere...
|
||||
|
||||
[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test
|
||||
[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test
|
||||
[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test
|
||||
[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test
|
||||
[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test
|
||||
[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test
|
||||
[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test
|
||||
[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test
|
||||
[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test
|
||||
[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test
|
||||
[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test
|
||||
[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
! Copyright (C) 2009 Alaric Snell-Pym
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: checksums classes.singleton kernel math math.ranges
|
||||
math.vectors sequences ;
|
||||
IN: checksums.fnv1
|
||||
|
||||
SINGLETON: fnv1-32
|
||||
SINGLETON: fnv1a-32
|
||||
SINGLETON: fnv1-64
|
||||
SINGLETON: fnv1a-64
|
||||
SINGLETON: fnv1-128
|
||||
SINGLETON: fnv1a-128
|
||||
SINGLETON: fnv1-256
|
||||
SINGLETON: fnv1a-256
|
||||
SINGLETON: fnv1-512
|
||||
SINGLETON: fnv1a-512
|
||||
SINGLETON: fnv1-1024
|
||||
SINGLETON: fnv1a-1024
|
||||
|
||||
CONSTANT: fnv1-32-prime 16777619
|
||||
CONSTANT: fnv1-64-prime 1099511628211
|
||||
CONSTANT: fnv1-128-prime 309485009821345068724781371
|
||||
CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
|
||||
CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
|
||||
CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
|
||||
|
||||
CONSTANT: fnv1-32-mod HEX: ffffffff
|
||||
CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
|
||||
CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
|
||||
CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
|
||||
CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
|
||||
CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
|
||||
|
||||
CONSTANT: fnv1-32-basis HEX: 811c9dc5
|
||||
CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
|
||||
CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
|
||||
CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
|
||||
CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
|
||||
CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
|
||||
|
||||
M: fnv1-32 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-32-basis swap
|
||||
[ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-32-basis swap
|
||||
[ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
|
||||
|
||||
|
||||
M: fnv1-64 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-64-basis swap
|
||||
[ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-64-basis swap
|
||||
[ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
|
||||
|
||||
|
||||
M: fnv1-128 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-128-basis swap
|
||||
[ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-128-basis swap
|
||||
[ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
|
||||
|
||||
|
||||
M: fnv1-256 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-256-basis swap
|
||||
[ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-256-basis swap
|
||||
[ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
|
||||
|
||||
|
||||
M: fnv1-512 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-512-basis swap
|
||||
[ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-512-basis swap
|
||||
[ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
|
||||
|
||||
|
||||
M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-1024-basis swap
|
||||
[ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
|
||||
|
||||
M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
fnv1-1024-basis swap
|
||||
[ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Fowler-Noll-Vo checksum algorithm
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
|
||||
io.streams.byte-array kernel math namespaces tools.test ;
|
||||
|
||||
IN: checksums.md5.tests
|
||||
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,13 +19,13 @@ C: <openssl-checksum> openssl-checksum
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: evp-md-context handle ;
|
||||
TUPLE: evp-md-context < disposable handle ;
|
||||
|
||||
: <evp-md-context> ( -- ctx )
|
||||
"EVP_MD_CTX" <c-object>
|
||||
dup EVP_MD_CTX_init evp-md-context boa ;
|
||||
evp-md-context new-disposable
|
||||
"EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
|
||||
|
||||
M: evp-md-context dispose
|
||||
M: evp-md-context dispose*
|
||||
handle>> EVP_MD_CTX_cleanup drop ;
|
||||
|
||||
: with-evp-md-context ( quot -- )
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
! See http;//factorcode.org/license.txt for BSD license
|
||||
USING: arrays kernel tools.test sequences sequences.private
|
||||
circular strings ;
|
||||
IN: circular.tests
|
||||
|
||||
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
|
||||
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ PRIVATE>
|
|||
|
||||
: push-growing-circular ( elt circular -- )
|
||||
dup full? [ push-circular ]
|
||||
[ [ 1+ ] change-length set-last ] if ;
|
||||
[ [ 1 + ] change-length set-last ] if ;
|
||||
|
||||
: <growing-circular> ( capacity -- growing-circular )
|
||||
{ } new-sequence 0 0 growing-circular boa ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,41 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors assocs classes classes.struct combinators
|
||||
kernel math prettyprint.backend prettyprint.custom
|
||||
prettyprint.sections see.private sequences strings 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 ;
|
||||
|
||||
: pprint-struct-slot ( slot -- )
|
||||
<flow \ { pprint-word
|
||||
{
|
||||
[ name>> text ]
|
||||
[ c-type>> dup string? [ text ] [ pprint* ] if ]
|
||||
[ read-only>> [ \ read-only pprint-word ] when ]
|
||||
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
|
||||
} cleave
|
||||
\ } pprint-word block> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: struct-class see-class*
|
||||
<colon dup struct-definer-word pprint-word dup pprint-word
|
||||
<block struct-slots [ pprint-struct-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 a C type." }
|
||||
{ { $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,205 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.libraries
|
||||
alien.structs.fields alien.syntax ascii classes.struct combinators
|
||||
destructors io.encodings.utf8 io.pathnames io.streams.string
|
||||
kernel libc literals math multiline namespaces prettyprint
|
||||
prettyprint.config see sequences specialized-arrays.ushort
|
||||
system tools.test compiler.tree.debugger struct-arrays
|
||||
classes.tuple.private specialized-arrays.direct.int
|
||||
compiler.units ;
|
||||
IN: classes.struct.tests
|
||||
|
||||
<<
|
||||
: libfactor-ffi-tests-path ( -- string )
|
||||
"resource:" (normalize-path)
|
||||
{
|
||||
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
|
||||
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
|
||||
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
|
||||
} cond append-path ;
|
||||
|
||||
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
|
||||
|
||||
"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
|
||||
>>
|
||||
|
||||
SYMBOL: struct-test-empty
|
||||
|
||||
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
|
||||
[ struct-must-have-slots? ] must-fail-with
|
||||
|
||||
STRUCT: struct-test-foo
|
||||
{ x char }
|
||||
{ y int initial: 123 }
|
||||
{ z bool } ;
|
||||
|
||||
STRUCT: struct-test-bar
|
||||
{ w ushort initial: HEX: ffff }
|
||||
{ foo struct-test-foo } ;
|
||||
|
||||
[ 12 ] [ struct-test-foo heap-size ] unit-test
|
||||
[ 12 ] [ struct-test-foo <struct> byte-length ] 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 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 drop ] with-destructors ] unit-test
|
||||
|
||||
STRUCT: struct-test-string-ptr
|
||||
{ x char* } ;
|
||||
|
||||
[ "hello world" ] [
|
||||
[
|
||||
struct-test-string-ptr <struct>
|
||||
"hello world" utf8 malloc-string &free >>x
|
||||
x>>
|
||||
] with-destructors
|
||||
] 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.struct ;
|
||||
IN: classes.struct.tests
|
||||
STRUCT: struct-test-foo
|
||||
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
|
||||
"> ]
|
||||
[ [ struct-test-foo see ] with-string-writer ] unit-test
|
||||
|
||||
[ <" USING: classes.struct ;
|
||||
IN: classes.struct.tests
|
||||
UNION-STRUCT: struct-test-float-and-bits
|
||||
{ f 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" }
|
||||
{ reader x>> }
|
||||
{ writer (>>x) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "y" }
|
||||
{ offset 4 }
|
||||
{ type "int" }
|
||||
{ reader y>> }
|
||||
{ writer (>>y) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "z" }
|
||||
{ offset 8 }
|
||||
{ type "bool" }
|
||||
{ reader z>> }
|
||||
{ writer (>>z) }
|
||||
}
|
||||
} ] [ "struct-test-foo" c-type fields>> ] unit-test
|
||||
|
||||
[ {
|
||||
T{ field-spec
|
||||
{ name "f" }
|
||||
{ offset 0 }
|
||||
{ type "float" }
|
||||
{ reader f>> }
|
||||
{ writer (>>f) }
|
||||
}
|
||||
T{ field-spec
|
||||
{ name "bits" }
|
||||
{ offset 0 }
|
||||
{ type "uint" }
|
||||
{ reader bits>> }
|
||||
{ writer (>>bits) }
|
||||
}
|
||||
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
|
||||
|
||||
STRUCT: struct-test-equality-1
|
||||
{ x int } ;
|
||||
STRUCT: struct-test-equality-2
|
||||
{ y int } ;
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
struct-test-equality-1 <struct> 5 >>x
|
||||
struct-test-equality-1 malloc-struct &free 5 >>x =
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
struct-test-equality-1 <struct> 5 >>x
|
||||
struct-test-equality-2 malloc-struct &free 5 >>y =
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
STRUCT: struct-test-ffi-foo
|
||||
{ x int }
|
||||
{ y int } ;
|
||||
|
||||
LIBRARY: f-cdecl
|
||||
FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
|
||||
|
||||
[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
|
||||
|
||||
STRUCT: struct-test-array-slots
|
||||
{ x int }
|
||||
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
|
||||
{ z int } ;
|
||||
|
||||
[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
|
||||
|
||||
[ t ] [
|
||||
struct-test-array-slots <struct>
|
||||
[ y>> [ 8 3 ] dip set-nth ]
|
||||
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
|
||||
] unit-test
|
||||
|
||||
STRUCT: struct-test-optimization
|
||||
{ x { "int" 3 } } { y int } ;
|
||||
|
||||
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
|
||||
[ t ] [
|
||||
[ 3 struct-test-optimization <direct-struct-array> third y>> ]
|
||||
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ struct-test-optimization memory>struct x>> second ]
|
||||
{ memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
|
||||
|
|
@ -0,0 +1,264 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors alien alien.c-types alien.structs
|
||||
alien.structs.fields arrays byte-arrays classes classes.parser
|
||||
classes.tuple classes.tuple.parser classes.tuple.private
|
||||
combinators combinators.short-circuit combinators.smart fry
|
||||
generalizations generic.parser kernel kernel.private lexer
|
||||
libc macros make math math.order parser quotations sequences
|
||||
slots slots.private struct-arrays vectors words
|
||||
compiler.tree.propagation.transforms ;
|
||||
FROM: slots => reader-word writer-word ;
|
||||
IN: classes.struct
|
||||
|
||||
! struct class
|
||||
|
||||
ERROR: struct-must-have-slots ;
|
||||
|
||||
TUPLE: struct
|
||||
{ (underlying) c-ptr read-only } ;
|
||||
|
||||
TUPLE: struct-slot-spec < slot-spec
|
||||
c-type ;
|
||||
|
||||
PREDICATE: struct-class < tuple-class
|
||||
{ [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
|
||||
|
||||
: struct-slots ( struct -- slots )
|
||||
"struct-slots" word-prop ;
|
||||
|
||||
! struct allocation
|
||||
|
||||
M: struct >c-ptr
|
||||
2 slot { c-ptr } declare ; inline
|
||||
|
||||
M: struct equal?
|
||||
{
|
||||
[ [ class ] bi@ = ]
|
||||
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
|
||||
} 2&& ;
|
||||
|
||||
: memory>struct ( ptr class -- struct )
|
||||
[ 1array ] dip slots>tuple ;
|
||||
|
||||
\ memory>struct [
|
||||
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
: malloc-struct ( class -- struct )
|
||||
[ heap-size malloc ] keep memory>struct ; inline
|
||||
|
||||
: (struct) ( class -- struct )
|
||||
[ heap-size <byte-array> ] keep memory>struct ; inline
|
||||
|
||||
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
||||
|
||||
: <struct> ( class -- struct )
|
||||
dup struct-prototype
|
||||
[ >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 )
|
||||
[ c-type>> c-type-getter-boxer ]
|
||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||
|
||||
: (writer-quot) ( slot -- quot )
|
||||
[ c-type>> 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 ;
|
||||
|
||||
: (define-byte-length-method) ( class -- )
|
||||
[ \ byte-length create-method-in ]
|
||||
[ heap-size \ drop swap [ ] 2sequence ] bi define ;
|
||||
|
||||
! Struct as c-type
|
||||
|
||||
: slot>field ( slot -- field )
|
||||
field-spec new swap {
|
||||
[ name>> >>name ]
|
||||
[ offset>> >>offset ]
|
||||
[ 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
|
||||
struct-type (define-struct)
|
||||
] [
|
||||
{
|
||||
[ name>> c-type ]
|
||||
[ (unboxer-quot) >>unboxer-quot ]
|
||||
[ (boxer-quot) >>boxer-quot ]
|
||||
[ >>boxed-class ]
|
||||
} cleave drop
|
||||
] bi ;
|
||||
|
||||
: align-offset ( offset class -- offset' )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( slots -- size )
|
||||
0 [
|
||||
[ c-type>> align-offset ] keep
|
||||
[ (>>offset) ] [ c-type>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
|
||||
: union-struct-offsets ( slots -- size )
|
||||
[ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
|
||||
|
||||
: struct-align ( slots -- align )
|
||||
[ c-type>> 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 ;
|
||||
|
||||
! class definition
|
||||
|
||||
: make-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-methods) ( class -- )
|
||||
[ (define-struct-slot-values-method) ]
|
||||
[ (define-byte-length-method) ] bi ;
|
||||
|
||||
: (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 make-struct-prototype "prototype" set-word-prop ]
|
||||
[ (struct-methods) ] tri ;
|
||||
|
||||
: check-struct-slots ( slots -- )
|
||||
[ c-type>> c-type drop ] each ;
|
||||
|
||||
: (define-struct-class) ( class slots offsets-quot -- )
|
||||
[
|
||||
[ struct-must-have-slots ]
|
||||
[ drop struct f define-tuple-class ] if-empty
|
||||
]
|
||||
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) ;
|
||||
|
||||
ERROR: invalid-struct-slot token ;
|
||||
|
||||
: struct-slot-class ( c-type -- class' )
|
||||
c-type c-type-boxed-class
|
||||
dup \ byte-array = [ drop \ c-ptr ] when ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
scan dup "{" = [ drop \ } parse-until >array ] when ;
|
||||
|
||||
: parse-struct-slot ( -- slot )
|
||||
struct-slot-spec new
|
||||
scan >>name
|
||||
scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi
|
||||
\ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
|
||||
|
||||
: parse-struct-slots ( slots -- slots' more? )
|
||||
scan {
|
||||
{ ";" [ f ] }
|
||||
{ "{" [ parse-struct-slot over push t ] }
|
||||
[ invalid-struct-slot ]
|
||||
} case ;
|
||||
|
||||
: parse-struct-definition ( -- class slots )
|
||||
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
|
||||
|
||||
SYNTAX: STRUCT:
|
||||
parse-struct-definition define-struct-class ;
|
||||
SYNTAX: UNION-STRUCT:
|
||||
parse-struct-definition define-union-struct-class ;
|
||||
|
||||
SYNTAX: S{
|
||||
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
|
||||
|
|
@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
|
|||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
|
||||
CONSTANT: NSAnyEventMask HEX: ffffffff
|
||||
|
||||
FUNCTION: void NSBeep ( ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2006 Kevin Reid.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: cocoa.callbacks
|
||||
USING: assocs kernel namespaces cocoa cocoa.classes
|
||||
cocoa.subclassing debugger ;
|
||||
IN: cocoa.callbacks
|
||||
|
||||
SYMBOL: callbacks
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: cocoa.tests
|
||||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
||||
compiler kernel namespaces cocoa.classes tools.test memory
|
||||
compiler.units math core-graphics.types ;
|
||||
IN: cocoa.tests
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ ERROR: no-objc-type name ;
|
|||
[ ] [ no-objc-type ] ?if ;
|
||||
|
||||
: (parse-objc-type) ( i string -- ctype )
|
||||
[ [ 1+ ] dip ] [ nth ] 2bi {
|
||||
[ [ 1 + ] dip ] [ nth ] 2bi {
|
||||
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
|
||||
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
|
||||
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: cocoa.plists.tests
|
||||
USING: tools.test cocoa.plists colors kernel hashtables
|
||||
core-foundation.utilities core-foundation destructors
|
||||
assocs cocoa.enumeration ;
|
||||
IN: cocoa.plists.tests
|
||||
|
||||
[
|
||||
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
|
||||
|
|
@ -37,4 +37,4 @@ assocs cocoa.enumeration ;
|
|||
[ 3.5 ] [
|
||||
3.5 >cf &CFRelease plist>
|
||||
] unit-test
|
||||
] with-destructors
|
||||
] with-destructors
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: specialized-arrays.int arrays kernel math namespaces make
|
||||
USING: arrays kernel math namespaces make
|
||||
cocoa cocoa.messages cocoa.classes core-graphics
|
||||
core-graphics.types sequences continuations accessors ;
|
||||
IN: cocoa.views
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math math.parser memoize
|
||||
io.encodings.ascii io.files lexer parser
|
||||
colors sequences splitting combinators.smart ascii ;
|
||||
USING: kernel assocs math math.parser memoize io.encodings.utf8
|
||||
io.files lexer parser colors sequences splitting
|
||||
combinators.smart ascii ;
|
||||
IN: colors.constants
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -19,7 +19,7 @@ IN: colors.constants
|
|||
[ parse-color ] H{ } map>assoc ;
|
||||
|
||||
MEMO: rgb.txt ( -- assoc )
|
||||
"resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
|
||||
"resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: colors.hsv.tests
|
||||
USING: accessors kernel colors colors.hsv tools.test math ;
|
||||
IN: colors.hsv.tests
|
||||
|
||||
: hsv>rgb ( h s v -- r g b )
|
||||
[ 360 * ] 2dip
|
||||
|
|
@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ;
|
|||
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
|
||||
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
|
||||
|
||||
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
|
||||
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: columns.tests
|
||||
USING: columns sequences kernel namespaces arrays tools.test math ;
|
||||
IN: columns.tests
|
||||
|
||||
! Columns
|
||||
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
|
||||
|
|
|
|||
|
|
@ -13,27 +13,27 @@ HELP: 0||
|
|||
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
|
||||
|
||||
HELP: 1&&
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 1||
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: 2&&
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 2||
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: 3&&
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 3||
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: n&&
|
||||
|
|
|
|||
|
|
@ -1,32 +1,18 @@
|
|||
|
||||
USING: kernel math tools.test combinators.short-circuit.smart ;
|
||||
|
||||
IN: combinators.short-circuit.smart.tests
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
|
||||
[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
|
||||
[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
|
||||
|
||||
: must-be-t ( in -- ) [ t ] swap unit-test ;
|
||||
: must-be-f ( in -- ) [ f ] swap unit-test ;
|
||||
[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
|
||||
[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
|
||||
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
|
||||
|
||||
[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
|
||||
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
|
||||
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
|
||||
[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
|
||||
|
||||
[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
|
||||
[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
|
||||
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
|
||||
|
||||
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
|
||||
|
||||
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
|
||||
|
||||
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
|
||||
|
||||
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
USING: kernel sequences math stack-checker effects accessors macros
|
||||
fry combinators.short-circuit ;
|
||||
USING: kernel sequences math stack-checker effects accessors
|
||||
macros fry combinators.short-circuit ;
|
||||
IN: combinators.short-circuit.smart
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: cannot-determine-arity ;
|
||||
|
||||
: arity ( quots -- n )
|
||||
first infer
|
||||
dup terminated?>> [ "Cannot determine arity" throw ] when
|
||||
effect-height neg 1+ ;
|
||||
dup terminated?>> [ cannot-determine-arity ] when
|
||||
effect-height neg 1 + ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ HELP: output>array
|
|||
{ $example
|
||||
<" USING: combinators combinators.smart math prettyprint ;
|
||||
9 [
|
||||
{ [ 1- ] [ 1+ ] [ sq ] } cleave
|
||||
{ [ 1 - ] [ 1 + ] [ sq ] } cleave
|
||||
] output>array .">
|
||||
"{ 8 10 81 }"
|
||||
}
|
||||
|
|
@ -71,7 +71,7 @@ HELP: sum-outputs
|
|||
{ $examples
|
||||
{ $example
|
||||
"USING: combinators.smart kernel math prettyprint ;"
|
||||
"10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
|
||||
"10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
|
||||
"20"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -106,11 +106,21 @@ HELP: append-outputs-as
|
|||
|
||||
{ append-outputs append-outputs-as } related-words
|
||||
|
||||
HELP: drop-outputs
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation and drops any values it leaves on the stack." } ;
|
||||
|
||||
HELP: keep-inputs
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation and preserves any values it takes off the stack." } ;
|
||||
|
||||
{ drop-outputs keep-inputs } related-words
|
||||
|
||||
ARTICLE: "combinators.smart" "Smart combinators"
|
||||
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
|
||||
"Call a quotation and discard all output values:"
|
||||
"Call a quotation and discard all output values or preserve all input values:"
|
||||
{ $subsection drop-outputs }
|
||||
{ $subsection keep-inputs }
|
||||
"Take all input values from a sequence:"
|
||||
{ $subsection input<sequence }
|
||||
"Store all output values to a sequence:"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
|
|||
IN: combinators.smart.tests
|
||||
|
||||
: test-bi ( -- 9 11 )
|
||||
10 [ 1- ] [ 1+ ] bi ;
|
||||
10 [ 1 - ] [ 1 + ] bi ;
|
||||
|
||||
[ [ test-bi ] output>array ] must-infer
|
||||
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
|
||||
|
|
@ -46,4 +46,4 @@ IN: combinators.smart.tests
|
|||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
|
||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors fry generalizations kernel macros math.order
|
||||
stack-checker math ;
|
||||
stack-checker math sequences ;
|
||||
IN: combinators.smart
|
||||
|
||||
MACRO: drop-outputs ( quot -- quot' )
|
||||
dup infer out>> '[ @ _ ndrop ] ;
|
||||
|
||||
MACRO: keep-inputs ( quot -- quot' )
|
||||
dup infer in>> '[ _ _ nkeep ] ;
|
||||
|
||||
MACRO: output>sequence ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip
|
||||
'[ @ _ _ nsequence ] ;
|
||||
|
|
@ -39,3 +42,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot )
|
|||
|
||||
MACRO: append-outputs ( quot -- seq )
|
||||
'[ _ { } append-outputs-as ] ;
|
||||
|
||||
MACRO: preserving ( quot -- )
|
||||
[ infer in>> length ] keep '[ _ ndup @ ] ;
|
||||
|
||||
MACRO: smart-if ( pred true false -- )
|
||||
'[ _ preserving _ _ if ] ; inline
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
IN: compiler.cfg.alias-analysis.tests
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes compiler.cfg
|
||||
accessors vectors combinators sets classes cpu.architecture compiler.cfg
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
|
||||
IN: compiler.cfg.alias-analysis
|
||||
|
|
@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
|
|||
SYMBOL: ac-counter
|
||||
|
||||
: next-ac ( -- n )
|
||||
ac-counter [ dup 1+ ] change ;
|
||||
ac-counter [ dup 1 + ] change ;
|
||||
|
||||
! Alias class for objects which are loaded from the data stack
|
||||
! or other object slots. We pessimistically assume that they
|
||||
|
|
@ -226,7 +226,7 @@ M: ##read analyze-aliases*
|
|||
call-next-method
|
||||
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
|
||||
2dup live-slot dup [
|
||||
2nip \ ##copy new-insn analyze-aliases* nip
|
||||
2nip any-rep \ ##copy new-insn analyze-aliases* nip
|
||||
] [
|
||||
drop remember-slot
|
||||
] if ;
|
||||
|
|
@ -285,4 +285,4 @@ M: insn eliminate-dead-stores* ;
|
|||
eliminate-dead-stores ;
|
||||
|
||||
: alias-analysis ( cfg -- cfg' )
|
||||
[ alias-analysis-step ] local-optimization ;
|
||||
[ alias-analysis-step ] local-optimization ;
|
||||
|
|
|
|||
|
|
@ -2,12 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences math
|
||||
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
compiler.cfg.predecessors compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.block-joining
|
||||
|
||||
! Joining blocks that are not calls and are connected by a single CFG edge.
|
||||
! Predecessors must be recomputed after this. Also this pass does not
|
||||
! update ##phi nodes and should therefore only run before stack analysis.
|
||||
! This pass does not update ##phi nodes and should therefore only run
|
||||
! before stack analysis.
|
||||
: join-block? ( bb -- ? )
|
||||
{
|
||||
[ kill-block? not ]
|
||||
|
|
@ -27,8 +27,11 @@ IN: compiler.cfg.block-joining
|
|||
[ join-instructions ] [ update-successors ] 2bi ;
|
||||
|
||||
: join-blocks ( cfg -- cfg' )
|
||||
needs-predecessors
|
||||
|
||||
dup post-order [
|
||||
dup join-block?
|
||||
[ dup predecessor join-block ] [ drop ] if
|
||||
] each
|
||||
cfg-changed ;
|
||||
|
||||
cfg-changed predecessors-changed ;
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ IN: compiler.cfg.branch-splitting.tests
|
|||
|
||||
: check-predecessors ( cfg -- )
|
||||
[ get-predecessors ]
|
||||
[ compute-predecessors drop ]
|
||||
[ needs-predecessors drop ]
|
||||
[ get-predecessors ] tri assert= ;
|
||||
|
||||
: check-branch-splitting ( cfg -- )
|
||||
compute-predecessors
|
||||
needs-predecessors
|
||||
split-branches
|
||||
check-predecessors ;
|
||||
|
||||
|
|
@ -46,11 +46,11 @@ V{ T{ ##branch } } 4 test-bb
|
|||
|
||||
V{ T{ ##branch } } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
0 { 1 2 } edges
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
1 { 3 4 } edges
|
||||
|
||||
2 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
2 { 3 4 } edges
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
|
|
@ -64,11 +64,11 @@ V{ T{ ##branch } } 3 test-bb
|
|||
|
||||
V{ T{ ##branch } } 4 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
0 { 1 2 } edges
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
1 { 3 4 } edges
|
||||
|
||||
2 get 4 get 1vector >>successors drop
|
||||
2 4 edge
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
|
|
@ -78,8 +78,8 @@ V{ T{ ##branch } } 1 test-bb
|
|||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
0 { 1 2 } edges
|
||||
|
||||
1 get 2 get 1vector >>successors drop
|
||||
1 2 edge
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel math math.order
|
||||
sequences assocs namespaces vectors fry arrays splitting
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
|
||||
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.branch-splitting
|
||||
|
||||
|
|
@ -81,7 +81,10 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
|
|||
] if ;
|
||||
|
||||
: split-branches ( cfg -- cfg' )
|
||||
needs-predecessors
|
||||
|
||||
dup [
|
||||
dup split-branch? [ split-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
|
||||
cfg-changed ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,13 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors math.order assocs kernel sequences
|
||||
combinators make classes words cpu.architecture
|
||||
combinators make classes words cpu.architecture layouts
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stack-frame ;
|
||||
IN: compiler.cfg.build-stack-frame
|
||||
|
||||
SYMBOL: frame-required?
|
||||
|
||||
SYMBOL: spill-counts
|
||||
|
||||
GENERIC: compute-stack-frame* ( insn -- )
|
||||
|
||||
: request-stack-frame ( stack-frame -- )
|
||||
|
|
@ -30,11 +28,11 @@ M: ##call compute-stack-frame*
|
|||
|
||||
M: _gc compute-stack-frame*
|
||||
frame-required? on
|
||||
stack-frame new swap gc-root-size>> >>gc-root-size
|
||||
stack-frame new swap tagged-values>> length cells >>gc-root-size
|
||||
request-stack-frame ;
|
||||
|
||||
M: _spill-counts compute-stack-frame*
|
||||
counts>> stack-frame get (>>spill-counts) ;
|
||||
M: _spill-area-size compute-stack-frame*
|
||||
n>> stack-frame get (>>spill-area-size) ;
|
||||
|
||||
M: insn compute-stack-frame*
|
||||
class frame-required? word-prop [
|
||||
|
|
@ -45,7 +43,7 @@ M: insn compute-stack-frame*
|
|||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
T{ stack-frame } clone stack-frame set
|
||||
stack-frame new stack-frame set
|
||||
[ compute-stack-frame* ] each
|
||||
stack-frame get dup stack-frame-size >>total-size drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
IN: compiler.cfg.builder.tests
|
||||
USING: tools.test kernel sequences words sequences.private fry
|
||||
prettyprint alien alien.accessors math.private compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
|
||||
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
|
||||
arrays locals byte-arrays kernel.private math slots.private vectors sbufs
|
||||
strings math.partial-dispatch strings.private ;
|
||||
compiler.cfg arrays locals byte-arrays kernel.private math
|
||||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
strings.private accessors compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
: unit-test-cfg ( quot -- )
|
||||
'[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
|
||||
'[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
|
||||
|
||||
: blahblah ( nodes -- ? )
|
||||
{ fixnum } declare [
|
||||
|
|
@ -156,3 +157,37 @@ strings math.partial-dispatch strings.private ;
|
|||
{ 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
|
||||
|
||||
[ f t ] [
|
||||
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
|
||||
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
||||
[ [ ##slot-imm? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
|
@ -19,6 +19,7 @@ compiler.cfg.instructions
|
|||
compiler.cfg.predecessors
|
||||
compiler.cfg.builder.blocks
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.stacks.local
|
||||
compiler.alien ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
|
|
@ -144,7 +145,7 @@ M: #dispatch emit-node
|
|||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
|
||||
! though.
|
||||
ds-pop ^^offset>slot i ##dispatch emit-if ;
|
||||
ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
|
||||
|
||||
! #call
|
||||
M: #call emit-node
|
||||
|
|
@ -159,14 +160,32 @@ M: #push emit-node
|
|||
literal>> ^^load-literal ds-push ;
|
||||
|
||||
! #shuffle
|
||||
|
||||
! Even though low level IR has its own dead code elimination pass,
|
||||
! we try not to introduce useless ##peeks here, since this reduces
|
||||
! the accuracy of global stack analysis.
|
||||
|
||||
: make-input-map ( #shuffle -- assoc )
|
||||
! Assoc maps high-level IR values to stack locations.
|
||||
[
|
||||
[ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
|
||||
[ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: make-output-seq ( values mapping input-map -- vregs )
|
||||
'[ _ at _ at peek-loc ] map ;
|
||||
|
||||
: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
|
||||
[ [ out-d>> ] 2dip make-output-seq ]
|
||||
[ [ out-r>> ] 2dip make-output-seq ] 3bi ;
|
||||
|
||||
: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
|
||||
[ [ in-d>> length neg inc-d ] dip ds-store ]
|
||||
[ [ in-r>> length neg inc-r ] dip rs-store ]
|
||||
bi-curry* bi ;
|
||||
|
||||
M: #shuffle emit-node
|
||||
dup
|
||||
H{ } clone
|
||||
[ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
|
||||
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
|
||||
[ nip ] 2tri
|
||||
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
|
||||
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
|
||||
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
|
||||
|
||||
! #return
|
||||
: emit-return ( -- )
|
||||
|
|
@ -227,3 +246,5 @@ M: #copy emit-node drop ;
|
|||
M: #enter-recursive emit-node drop ;
|
||||
|
||||
M: #phi emit-node drop ;
|
||||
|
||||
M: #declare emit-node drop ;
|
||||
|
|
@ -19,11 +19,28 @@ M: basic-block hashcode* nip id>> ;
|
|||
V{ } clone >>predecessors
|
||||
\ basic-block counter >>id ;
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||
TUPLE: cfg { entry basic-block } word label
|
||||
spill-area-size reps
|
||||
post-order linear-order
|
||||
predecessors-valid? dominance-valid? loops-valid? ;
|
||||
|
||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||
: <cfg> ( entry word label -- cfg )
|
||||
cfg new
|
||||
swap >>label
|
||||
swap >>word
|
||||
swap >>entry ;
|
||||
|
||||
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
|
||||
: cfg-changed ( cfg -- cfg )
|
||||
f >>post-order
|
||||
f >>linear-order
|
||||
f >>dominance-valid?
|
||||
f >>loops-valid? ; inline
|
||||
|
||||
: predecessors-changed ( cfg -- cfg )
|
||||
f >>predecessors-valid? ;
|
||||
|
||||
: with-cfg ( cfg quot: ( cfg -- ) -- )
|
||||
[ dup cfg ] dip with-variable ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,17 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces assocs accessors sequences grouping
|
||||
compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
|
||||
combinators compiler.cfg.rpo compiler.cfg.renaming
|
||||
compiler.cfg.instructions compiler.cfg.predecessors ;
|
||||
IN: compiler.cfg.copy-prop
|
||||
|
||||
! The first three definitions are also used in compiler.cfg.alias-analysis.
|
||||
SYMBOL: copies
|
||||
|
||||
! Initialized per-basic-block; a mapping from inputs to dst for eliminating
|
||||
! redundant phi instructions
|
||||
SYMBOL: phis
|
||||
|
||||
: resolve ( vreg -- vreg )
|
||||
copies get ?at drop ;
|
||||
|
||||
|
|
@ -22,17 +27,27 @@ GENERIC: visit-insn ( insn -- )
|
|||
|
||||
M: ##copy visit-insn record-copy ;
|
||||
|
||||
: useless-phi ( dst inputs -- ) first (record-copy) ;
|
||||
|
||||
: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
|
||||
|
||||
: record-phi ( dst inputs -- ) phis get set-at ;
|
||||
|
||||
M: ##phi visit-insn
|
||||
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
|
||||
dup all-equal? [ first (record-copy) ] [ 2drop ] if ;
|
||||
{
|
||||
{ [ dup all-equal? ] [ useless-phi ] }
|
||||
{ [ dup phis get key? ] [ redundant-phi ] }
|
||||
[ record-phi ]
|
||||
} cond ;
|
||||
|
||||
M: insn visit-insn drop ;
|
||||
|
||||
: collect-copies ( cfg -- )
|
||||
H{ } clone copies set
|
||||
[
|
||||
instructions>>
|
||||
[ visit-insn ] each
|
||||
H{ } clone phis set
|
||||
instructions>> [ visit-insn ] each
|
||||
] each-basic-block ;
|
||||
|
||||
GENERIC: update-insn ( insn -- keep? )
|
||||
|
|
@ -48,14 +63,15 @@ M: insn update-insn rename-insn-uses t ;
|
|||
copies get dup assoc-empty? [ 2drop ] [
|
||||
renamings set
|
||||
[
|
||||
instructions>>
|
||||
[ update-insn ] filter-here
|
||||
instructions>> [ update-insn ] filter-here
|
||||
] each-basic-block
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: copy-propagation ( cfg -- cfg' )
|
||||
needs-predecessors
|
||||
|
||||
[ collect-copies ]
|
||||
[ rename-copies ]
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -1,21 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math accessors sequences
|
||||
compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.critical-edges
|
||||
|
||||
: critical-edge? ( from to -- ? )
|
||||
[ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
|
||||
|
||||
: split-critical-edge ( from to -- )
|
||||
f <simple-block> insert-basic-block ;
|
||||
|
||||
: split-critical-edges ( cfg -- )
|
||||
dup [
|
||||
dup successors>> [
|
||||
2dup critical-edge?
|
||||
[ split-critical-edge ] [ 2drop ] if
|
||||
] with each
|
||||
] each-basic-block
|
||||
cfg-changed
|
||||
drop ;
|
||||
|
|
@ -2,10 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists kernel locals sequences lexer
|
||||
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
|
||||
compiler.cfg ;
|
||||
compiler.cfg.predecessors compiler.cfg ;
|
||||
IN: compiler.cfg.dataflow-analysis
|
||||
|
||||
GENERIC: join-sets ( sets dfa -- set )
|
||||
GENERIC: join-sets ( sets bb dfa -- set )
|
||||
GENERIC: transfer-set ( in-set bb dfa -- out-set )
|
||||
GENERIC: block-order ( cfg dfa -- bbs )
|
||||
GENERIC: successors ( bb dfa -- seq )
|
||||
|
|
@ -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 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
|
||||
|
|
@ -48,6 +52,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
|
|||
] when ; inline
|
||||
|
||||
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
|
||||
cfg needs-predecessors drop
|
||||
H{ } clone :> in-sets
|
||||
H{ } clone :> out-sets
|
||||
cfg dfa <dfa-worklist> :> work-list
|
||||
|
|
@ -55,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
|
|||
in-sets
|
||||
out-sets ; inline
|
||||
|
||||
M: dataflow-analysis join-sets drop assoc-refine ;
|
||||
M: dataflow-analysis join-sets 2drop assoc-refine ;
|
||||
|
||||
FUNCTOR: define-analysis ( name -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -11,62 +11,62 @@ IN: compiler.cfg.dce.tests
|
|||
entry>> instructions>> ;
|
||||
|
||||
[ V{
|
||||
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
|
||||
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 3 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst 2 } { val 16 } }
|
||||
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
|
||||
T{ ##replace { src 3 } { loc D 0 } }
|
||||
} ] [ V{
|
||||
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
|
||||
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 3 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst 2 } { val 16 } }
|
||||
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
|
||||
T{ ##replace { src 3 } { loc D 0 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{ } ] [ V{
|
||||
T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
|
||||
T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
|
||||
T{ ##load-immediate { dst 1 } { val 8 } }
|
||||
T{ ##load-immediate { dst 2 } { val 16 } }
|
||||
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{ } ] [ V{
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{ } ] [ V{
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##set-slot-imm { obj 1 } { src 3 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##set-slot-imm { obj 1 } { src 3 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
} ] [ V{
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##set-slot-imm { obj 1 } { src 3 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
} ] [ V{
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
} test-dce ] unit-test
|
||||
|
||||
[ V{
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##set-slot-imm { obj 1 } { src 3 } }
|
||||
} ] [ V{
|
||||
T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
|
||||
T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
|
||||
T{ ##allot { dst 1 } { temp 2 } }
|
||||
T{ ##replace { src 1 } { loc D 0 } }
|
||||
T{ ##load-immediate { dst 3 } { val 8 } }
|
||||
T{ ##set-slot-imm { obj 1 } { src 3 } }
|
||||
} test-dce ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sets kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.def-use
|
||||
compiler.cfg.rpo ;
|
||||
compiler.cfg.rpo compiler.cfg.predecessors ;
|
||||
IN: compiler.cfg.dce
|
||||
|
||||
! Maps vregs to sequences of vregs
|
||||
|
|
@ -95,6 +95,8 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
|
|||
M: insn live-insn? drop t ;
|
||||
|
||||
: eliminate-dead-code ( cfg -- cfg' )
|
||||
needs-predecessors
|
||||
|
||||
init-dead-code
|
||||
dup
|
||||
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
|
||||
|
|
|
|||
|
|
@ -1,14 +1,16 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel words sequences quotations namespaces io vectors
|
||||
classes.tuple accessors prettyprint prettyprint.config
|
||||
prettyprint.backend prettyprint.custom prettyprint.sections
|
||||
parser compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.linearization
|
||||
compiler.cfg.registers compiler.cfg.stack-frame
|
||||
compiler.cfg.linear-scan compiler.cfg.two-operand
|
||||
compiler.cfg.optimizer
|
||||
compiler.cfg.mr compiler.cfg ;
|
||||
arrays hashtables classes.tuple accessors prettyprint
|
||||
prettyprint.config assocs prettyprint.backend prettyprint.custom
|
||||
prettyprint.sections parser compiler.tree.builder
|
||||
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
|
||||
compiler.cfg.linearization compiler.cfg.registers
|
||||
compiler.cfg.stack-frame compiler.cfg.linear-scan
|
||||
compiler.cfg.two-operand compiler.cfg.optimizer
|
||||
compiler.cfg.instructions compiler.cfg.utilities
|
||||
compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
|
||||
compiler.cfg.representations.preferred compiler.cfg ;
|
||||
IN: compiler.cfg.debugger
|
||||
|
||||
GENERIC: test-cfg ( quot -- cfgs )
|
||||
|
|
@ -23,8 +25,10 @@ M: word test-cfg
|
|||
|
||||
: test-mr ( quot -- mrs )
|
||||
test-cfg [
|
||||
optimize-cfg
|
||||
build-mr
|
||||
[
|
||||
optimize-cfg
|
||||
build-mr
|
||||
] with-cfg
|
||||
] map ;
|
||||
|
||||
: insn. ( insn -- )
|
||||
|
|
@ -41,22 +45,38 @@ M: word test-cfg
|
|||
] each ;
|
||||
|
||||
! Prettyprinting
|
||||
M: vreg pprint*
|
||||
<block
|
||||
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
|
||||
block> ;
|
||||
|
||||
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
||||
M: ds-loc pprint* \ D pprint-loc ;
|
||||
|
||||
M: rs-loc pprint* \ R pprint-loc ;
|
||||
|
||||
: resolve-phis ( bb -- )
|
||||
[
|
||||
[ [ [ get ] dip ] assoc-map ] change-inputs drop
|
||||
] each-phi ;
|
||||
|
||||
: test-bb ( insns n -- )
|
||||
[ <basic-block> swap >>number swap >>instructions ] keep set ;
|
||||
[ <basic-block> swap >>number swap >>instructions dup ] keep set
|
||||
resolve-phis ;
|
||||
|
||||
: edge ( from to -- )
|
||||
[ get ] bi@ 1vector >>successors drop ;
|
||||
|
||||
: edges ( from tos -- )
|
||||
[ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
|
||||
|
||||
: test-diamond ( -- )
|
||||
1 get 1vector 0 get (>>successors)
|
||||
2 get 3 get V{ } 2sequence 1 get (>>successors)
|
||||
4 get 1vector 2 get (>>successors)
|
||||
4 get 1vector 3 get (>>successors) ;
|
||||
0 1 edge
|
||||
1 { 2 3 } edges
|
||||
2 4 edge
|
||||
3 4 edge ;
|
||||
|
||||
: fake-representations ( cfg -- )
|
||||
post-order [
|
||||
instructions>> [
|
||||
[ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
|
||||
[ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
|
||||
bi [ suffix ] when*
|
||||
] map concat
|
||||
] map concat >hashtable representations set ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test accessors vectors sequences namespaces
|
||||
arrays
|
||||
cpu.architecture
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.cfg.def-use.tests
|
||||
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 0 }
|
||||
T{ ##peek f 2 D 0 }
|
||||
} 1 test-bb
|
||||
V{
|
||||
T{ ##replace f 2 D 0 }
|
||||
} 2 test-bb
|
||||
1 2 edge
|
||||
V{
|
||||
T{ ##replace f 0 D 0 }
|
||||
} 3 test-bb
|
||||
2 3 edge
|
||||
V{ } 4 test-bb
|
||||
V{ } 5 test-bb
|
||||
3 { 4 5 } edges
|
||||
V{
|
||||
T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
|
||||
} 6 test-bb
|
||||
4 6 edge
|
||||
5 6 edge
|
||||
|
||||
cfg new 1 get >>entry 0 set
|
||||
[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel assocs sequences namespaces fry
|
||||
sets compiler.cfg.rpo compiler.cfg.instructions ;
|
||||
sets compiler.cfg.rpo compiler.cfg.instructions locals ;
|
||||
IN: compiler.cfg.def-use
|
||||
|
||||
GENERIC: defs-vreg ( insn -- vreg/f )
|
||||
|
|
@ -21,6 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
|
|||
M: ##set-slot temp-vregs temp>> 1array ;
|
||||
M: ##string-nth temp-vregs temp>> 1array ;
|
||||
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
|
||||
M: ##box-displaced-alien temp-vregs temp>> 1array ;
|
||||
M: ##compare temp-vregs temp>> 1array ;
|
||||
M: ##compare-imm temp-vregs temp>> 1array ;
|
||||
M: ##compare-float temp-vregs temp>> 1array ;
|
||||
|
|
@ -80,18 +81,15 @@ SYMBOLS: defs insns uses ;
|
|||
] each-basic-block
|
||||
] keep insns set ;
|
||||
|
||||
: compute-uses ( cfg -- )
|
||||
H{ } clone [
|
||||
'[
|
||||
dup instructions>> [
|
||||
uses-vregs [
|
||||
_ conjoin-at
|
||||
] with each
|
||||
] with each
|
||||
] each-basic-block
|
||||
] keep
|
||||
[ keys ] assoc-map
|
||||
uses set ;
|
||||
|
||||
: compute-def-use ( cfg -- )
|
||||
[ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;
|
||||
:: compute-uses ( cfg -- )
|
||||
! Here, a phi node uses its argument in the block that it comes from.
|
||||
H{ } clone :> use
|
||||
cfg [| block |
|
||||
block instructions>> [
|
||||
dup ##phi?
|
||||
[ inputs>> [ use conjoin-at ] assoc-each ]
|
||||
[ uses-vregs [ block swap use conjoin-at ] each ]
|
||||
if
|
||||
] each
|
||||
] each-basic-block
|
||||
use [ keys ] assoc-map uses set ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
IN: compiler.cfg.dominance.tests
|
||||
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
|
||||
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
|
||||
compiler.cfg.predecessors ;
|
||||
IN: compiler.cfg.dominance.tests
|
||||
|
||||
: test-dominance ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-dominance ;
|
||||
needs-dominance drop ;
|
||||
|
||||
! Example with no back edges
|
||||
V{ } 0 test-bb
|
||||
|
|
@ -16,11 +15,11 @@ V{ } 3 test-bb
|
|||
V{ } 4 test-bb
|
||||
V{ } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
0 { 1 2 } edges
|
||||
1 3 edge
|
||||
2 4 edge
|
||||
3 4 edge
|
||||
4 5 edge
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
|
|
@ -46,11 +45,11 @@ V{ } 2 test-bb
|
|||
V{ } 3 test-bb
|
||||
V{ } 4 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 3 get 1vector >>successors drop
|
||||
0 { 1 2 } edges
|
||||
1 3 edge
|
||||
2 4 edge
|
||||
3 4 edge
|
||||
4 3 edge
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
|
|
@ -64,12 +63,12 @@ V{ } 3 test-bb
|
|||
V{ } 4 test-bb
|
||||
V{ } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 5 get 1vector >>successors drop
|
||||
2 get 4 get 3 get V{ } 2sequence >>successors drop
|
||||
5 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 3 get V{ } 2sequence >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
0 { 1 2 } edges
|
||||
1 5 edge
|
||||
2 { 4 3 } edges
|
||||
5 4 edge
|
||||
4 { 5 3 } edges
|
||||
3 4 edge
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators sets math fry kernel math.order
|
||||
dlists deques vectors namespaces sequences sorting locals
|
||||
compiler.cfg.rpo ;
|
||||
compiler.cfg.rpo compiler.cfg.predecessors ;
|
||||
IN: compiler.cfg.dominance
|
||||
|
||||
! Reference:
|
||||
|
|
@ -83,10 +83,14 @@ PRIVATE>
|
|||
H{ } clone maxpreorder set
|
||||
[ 0 ] dip entry>> (compute-dfs) drop ;
|
||||
|
||||
: compute-dominance ( cfg -- cfg' )
|
||||
[ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-dominance ( cfg -- )
|
||||
[ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
|
||||
: needs-dominance ( cfg -- cfg' )
|
||||
needs-predecessors
|
||||
dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
|
||||
|
||||
: dominates? ( bb1 bb2 -- ? )
|
||||
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,12 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
USING: kernel accessors sequences namespaces combinators
|
||||
combinators.short-circuit classes vectors compiler.cfg
|
||||
compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.empty-blocks
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: update-predecessor ( bb -- )
|
||||
! We have to replace occurrences of bb with bb's successor
|
||||
! in bb's predecessor's list of successors.
|
||||
|
|
@ -21,9 +24,12 @@ IN: compiler.cfg.empty-blocks
|
|||
2dup eq? [ drop predecessors>> first ] [ nip ] if
|
||||
] with map
|
||||
] change-predecessors drop ;
|
||||
|
||||
|
||||
SYMBOL: changed?
|
||||
|
||||
: delete-basic-block ( bb -- )
|
||||
[ update-predecessor ] [ update-successor ] bi ;
|
||||
[ update-predecessor ] [ update-successor ] bi
|
||||
changed? on ;
|
||||
|
||||
: delete-basic-block? ( bb -- ? )
|
||||
{
|
||||
|
|
@ -32,7 +38,10 @@ IN: compiler.cfg.empty-blocks
|
|||
[ successors>> length 1 = ]
|
||||
[ instructions>> first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: delete-empty-blocks ( cfg -- cfg' )
|
||||
changed? off
|
||||
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
|
||||
cfg-changed ;
|
||||
changed? get [ cfg-changed ] when ;
|
||||
|
|
@ -1,26 +1,26 @@
|
|||
IN: compiler.cfg.gc-checks.tests
|
||||
USING: compiler.cfg.gc-checks compiler.cfg.debugger
|
||||
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
|
||||
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
|
||||
namespaces accessors sequences ;
|
||||
IN: compiler.cfg.gc-checks.tests
|
||||
|
||||
: test-gc-checks ( -- )
|
||||
H{ } clone representations set
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
insert-gc-checks
|
||||
drop ;
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 3 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f 0 D 1 }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##box-float f V int-regs 0 V int-regs 1 }
|
||||
T{ ##box-float f 0 1 }
|
||||
} 1 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
0 1 edge
|
||||
|
||||
[ ] [ test-gc-checks ] unit-test
|
||||
|
||||
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
|
||||
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,13 +1,16 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs fry
|
||||
cpu.architecture
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.stacks.uninitialized ;
|
||||
IN: compiler.cfg.gc-checks
|
||||
|
||||
! Garbage collection check insertion. This pass runs after representation
|
||||
! selection, so it must keep track of representations.
|
||||
|
||||
: insert-gc-check? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
||||
|
|
@ -16,7 +19,9 @@ IN: compiler.cfg.gc-checks
|
|||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup '[
|
||||
i i f _ uninitialized-locs \ ##gc new-insn
|
||||
int-rep next-vreg-rep
|
||||
int-rep next-vreg-rep
|
||||
f f _ uninitialized-locs \ ##gc new-insn
|
||||
prefix
|
||||
] change-instructions drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,83 +1,81 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays kernel layouts math namespaces
|
||||
USING: accessors arrays byte-arrays kernel layouts math namespaces
|
||||
sequences classes.tuple cpu.architecture compiler.cfg.registers
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.hats
|
||||
|
||||
: i ( -- vreg ) int-regs next-vreg ; inline
|
||||
: ^^i ( -- vreg vreg ) i dup ; inline
|
||||
: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
|
||||
: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
|
||||
: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
|
||||
: ^^r ( -- vreg vreg ) next-vreg dup ; inline
|
||||
: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
|
||||
: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
|
||||
: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
|
||||
|
||||
: d ( -- vreg ) double-float-regs next-vreg ; inline
|
||||
: ^^d ( -- vreg vreg ) d dup ; inline
|
||||
: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
|
||||
: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
|
||||
: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
|
||||
|
||||
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
|
||||
: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
|
||||
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
|
||||
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
|
||||
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
|
||||
: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
|
||||
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
|
||||
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
|
||||
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
|
||||
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
|
||||
: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
|
||||
: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
|
||||
: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
|
||||
: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
|
||||
: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
|
||||
: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
|
||||
: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
|
||||
: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
|
||||
: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
|
||||
: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
|
||||
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
|
||||
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
|
||||
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
|
||||
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
|
||||
: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
|
||||
: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
|
||||
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
|
||||
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
|
||||
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
|
||||
: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
|
||||
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
|
||||
: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
|
||||
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
|
||||
: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
|
||||
: ^^not ( src -- dst ) ^^i1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
|
||||
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
|
||||
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
|
||||
: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
|
||||
: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
|
||||
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
|
||||
: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
|
||||
: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
|
||||
: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
|
||||
: ^^and ( input mask -- output ) ^^r2 ##and ; inline
|
||||
: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
|
||||
: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
|
||||
: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
|
||||
: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
|
||||
: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
|
||||
: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
|
||||
: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
|
||||
: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
|
||||
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
|
||||
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
|
||||
: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
|
||||
: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
|
||||
: ^^not ( src -- dst ) ^^r1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
|
||||
: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
|
||||
: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
|
||||
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
|
||||
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
|
||||
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
|
||||
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
|
||||
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
|
||||
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
|
||||
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
|
||||
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
||||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
|
||||
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
|
||||
: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
|
||||
: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
|
||||
: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
|
||||
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
|
||||
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
|
||||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
|
||||
: ^^box-displaced-alien ( base displacement base-class -- dst )
|
||||
^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
|
||||
: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
|
||||
: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
|
||||
: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
|
||||
: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
|
||||
: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
|
||||
: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
|
||||
: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
|
||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
||||
: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
|
||||
: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
|
||||
: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
|
||||
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
|
||||
: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
|
||||
: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
|
||||
: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
|
||||
: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue