Merge branch 'new_gc' of git://factorcode.org/git/factor into new_gc
Slava Pestov
commit
85dc9fda26
4
Makefile
4
Makefile
|
|
@ -41,6 +41,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm/callstack.o \
|
||||
vm/code_block.o \
|
||||
vm/code_heap.o \
|
||||
vm/compaction.o \
|
||||
vm/contexts.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
|
|
@ -49,14 +50,13 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm/factor.o \
|
||||
vm/full_collector.o \
|
||||
vm/gc.o \
|
||||
vm/heap.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/math.o \
|
||||
vm/nursery_collector.o \
|
||||
vm/old_space.o \
|
||||
vm/object_start_map.o \
|
||||
vm/primitives.o \
|
||||
vm/profiler.o \
|
||||
vm/quotations.o \
|
||||
|
|
|
|||
|
|
@ -1,18 +1,19 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.data alien.strings parser
|
||||
threads words kernel.private kernel io.encodings.utf8 eval ;
|
||||
USING: accessors alien alien.c-types alien.data alien.strings
|
||||
parser threads words kernel.private kernel io.encodings.utf8
|
||||
eval ;
|
||||
IN: alien.remote-control
|
||||
|
||||
: eval-callback ( -- callback )
|
||||
"void*" { "char*" } "cdecl"
|
||||
void* { char* } "cdecl"
|
||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||
|
||||
: yield-callback ( -- callback )
|
||||
"void" { } "cdecl" [ yield ] alien-callback ;
|
||||
void { } "cdecl" [ yield ] alien-callback ;
|
||||
|
||||
: sleep-callback ( -- callback )
|
||||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||
void { long } "cdecl" [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
|
|
|||
|
|
@ -218,8 +218,12 @@ USERENV: undefined-quot 60
|
|||
|
||||
: here-as ( tag -- pointer ) here bitor ;
|
||||
|
||||
: (align-here) ( alignment -- )
|
||||
[ here neg ] dip rem
|
||||
[ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
|
||||
|
||||
: align-here ( -- )
|
||||
here 8 mod 4 = [ 0 emit ] when ;
|
||||
data-alignment get (align-here) ;
|
||||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
|
|
@ -293,7 +297,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
|||
M: float '
|
||||
[
|
||||
float [
|
||||
align-here double>bits emit-64
|
||||
8 (align-here) double>bits emit-64
|
||||
] emit-object
|
||||
] cache-eql-object ;
|
||||
|
||||
|
|
@ -411,6 +415,7 @@ M: byte-array '
|
|||
[
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
bootstrap-cell 4 = [ 0 emit 0 emit ] when
|
||||
pad-bytes emit-bytes
|
||||
] emit-object
|
||||
] cache-eq-object ;
|
||||
|
|
|
|||
|
|
@ -77,8 +77,6 @@ SYMBOL: bootstrap-time
|
|||
"stage2: deployment mode" print
|
||||
] [
|
||||
"debugger" require
|
||||
"inspector" require
|
||||
"tools.errors" require
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -2,8 +2,10 @@ USING: vocabs.loader sequences ;
|
|||
IN: bootstrap.tools
|
||||
|
||||
{
|
||||
"editors"
|
||||
"inspector"
|
||||
"bootstrap.image"
|
||||
"see"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.errors"
|
||||
|
|
@ -19,5 +21,4 @@ IN: bootstrap.tools
|
|||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@ CLASS: {
|
|||
{ +superclass+ "NSObject" }
|
||||
}
|
||||
|
||||
{ "perform:" "void" { "id" "SEL" "id" }
|
||||
{ "perform:" void { id SEL id }
|
||||
[ 2drop callbacks get at try ]
|
||||
}
|
||||
|
||||
{ "dealloc" "void" { "id" "SEL" }
|
||||
{ "dealloc" void { id SEL }
|
||||
[
|
||||
drop
|
||||
dup callbacks get delete-at
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
||||
compiler kernel namespaces cocoa.classes tools.test memory
|
||||
compiler.units math core-graphics.types ;
|
||||
compiler kernel namespaces cocoa.classes cocoa.runtime
|
||||
tools.test memory compiler.units math core-graphics.types ;
|
||||
FROM: alien.c-types => int void ;
|
||||
IN: cocoa.tests
|
||||
|
||||
CLASS: {
|
||||
|
|
@ -8,8 +9,8 @@ CLASS: {
|
|||
{ +name+ "Foo" }
|
||||
} {
|
||||
"foo:"
|
||||
"void"
|
||||
{ "id" "SEL" "NSRect" }
|
||||
void
|
||||
{ id SEL NSRect }
|
||||
[ gc "x" set 2drop ]
|
||||
} ;
|
||||
|
||||
|
|
@ -30,8 +31,8 @@ CLASS: {
|
|||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar"
|
||||
"NSRect"
|
||||
{ "id" "SEL" }
|
||||
NSRect
|
||||
{ id SEL }
|
||||
[ 2drop test-foo "x" get ]
|
||||
} ;
|
||||
|
||||
|
|
@ -52,13 +53,13 @@ CLASS: {
|
|||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar"
|
||||
"NSRect"
|
||||
{ "id" "SEL" }
|
||||
NSRect
|
||||
{ id SEL }
|
||||
[ 2drop test-foo "x" get ]
|
||||
} {
|
||||
"babb"
|
||||
"int"
|
||||
{ "id" "SEL" "int" }
|
||||
int
|
||||
{ id SEL int }
|
||||
[ 2nip sq ]
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ;
|
|||
IN: cocoa.messages
|
||||
|
||||
HELP: send
|
||||
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
|
||||
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
|
||||
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
|
||||
|
||||
HELP: super-send
|
||||
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
|
||||
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
|
||||
|
||||
HELP: objc-class
|
||||
|
|
|
|||
|
|
@ -2,10 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
classes.struct continuations combinators compiler compiler.alien
|
||||
stack-checker kernel math namespaces make quotations sequences
|
||||
strings words cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private lexer init core-foundation fry
|
||||
generalizations specialized-arrays ;
|
||||
core-graphics.types stack-checker kernel math namespaces make
|
||||
quotations sequences strings words cocoa.runtime cocoa.types io
|
||||
macros memoize io.encodings.utf8 effects layouts libc
|
||||
libc.private lexer init core-foundation fry generalizations
|
||||
specialized-arrays ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: cocoa.messages
|
||||
|
||||
SPECIALIZED-ARRAY: void*
|
||||
|
|
@ -98,75 +100,84 @@ class-init-hooks [ H{ } clone ] initialize
|
|||
SYMBOL: objc>alien-types
|
||||
|
||||
H{
|
||||
{ "c" "char" }
|
||||
{ "i" "int" }
|
||||
{ "s" "short" }
|
||||
{ "C" "uchar" }
|
||||
{ "I" "uint" }
|
||||
{ "S" "ushort" }
|
||||
{ "f" "float" }
|
||||
{ "d" "double" }
|
||||
{ "B" "bool" }
|
||||
{ "v" "void" }
|
||||
{ "*" "char*" }
|
||||
{ "?" "unknown_type" }
|
||||
{ "@" "id" }
|
||||
{ "#" "Class" }
|
||||
{ ":" "SEL" }
|
||||
{ "c" c:char }
|
||||
{ "i" c:int }
|
||||
{ "s" c:short }
|
||||
{ "C" c:uchar }
|
||||
{ "I" c:uint }
|
||||
{ "S" c:ushort }
|
||||
{ "f" c:float }
|
||||
{ "d" c:double }
|
||||
{ "B" c:bool }
|
||||
{ "v" c:void }
|
||||
{ "*" c:char* }
|
||||
{ "?" unknown_type }
|
||||
{ "@" id }
|
||||
{ "#" Class }
|
||||
{ ":" SEL }
|
||||
}
|
||||
"ptrdiff_t" heap-size {
|
||||
cell {
|
||||
{ 4 [ H{
|
||||
{ "l" "long" }
|
||||
{ "q" "longlong" }
|
||||
{ "L" "ulong" }
|
||||
{ "Q" "ulonglong" }
|
||||
{ "l" c:long }
|
||||
{ "q" c:longlong }
|
||||
{ "L" c:ulong }
|
||||
{ "Q" c:ulonglong }
|
||||
} ] }
|
||||
{ 8 [ H{
|
||||
{ "l" "long32" }
|
||||
{ "q" "long" }
|
||||
{ "L" "ulong32" }
|
||||
{ "Q" "ulong" }
|
||||
{ "l" long32 }
|
||||
{ "q" long }
|
||||
{ "L" ulong32 }
|
||||
{ "Q" ulong }
|
||||
} ] }
|
||||
} case
|
||||
assoc-union objc>alien-types set-global
|
||||
|
||||
SYMBOL: objc>struct-types
|
||||
|
||||
H{
|
||||
{ "_NSPoint" NSPoint }
|
||||
{ "NSPoint" NSPoint }
|
||||
{ "CGPoint" NSPoint }
|
||||
{ "_NSRect" NSRect }
|
||||
{ "NSRect" NSRect }
|
||||
{ "CGRect" NSRect }
|
||||
{ "_NSSize" NSSize }
|
||||
{ "NSSize" NSSize }
|
||||
{ "CGSize" NSSize }
|
||||
{ "_NSRange" NSRange }
|
||||
{ "NSRange" NSRange }
|
||||
} objc>struct-types set-global
|
||||
|
||||
! The transpose of the above map
|
||||
SYMBOL: alien>objc-types
|
||||
|
||||
objc>alien-types get [ swap ] assoc-map
|
||||
! A hack...
|
||||
"ptrdiff_t" heap-size {
|
||||
cell {
|
||||
{ 4 [ H{
|
||||
{ "NSPoint" "{_NSPoint=ff}" }
|
||||
{ "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
|
||||
{ "NSSize" "{_NSSize=ff}" }
|
||||
{ "NSRange" "{_NSRange=II}" }
|
||||
{ "NSInteger" "i" }
|
||||
{ "NSUInteger" "I" }
|
||||
{ "CGFloat" "f" }
|
||||
{ NSPoint "{_NSPoint=ff}" }
|
||||
{ NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
|
||||
{ NSSize "{_NSSize=ff}" }
|
||||
{ NSRange "{_NSRange=II}" }
|
||||
{ NSInteger "i" }
|
||||
{ NSUInteger "I" }
|
||||
{ CGFloat "f" }
|
||||
} ] }
|
||||
{ 8 [ H{
|
||||
{ "NSPoint" "{CGPoint=dd}" }
|
||||
{ "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
|
||||
{ "NSSize" "{CGSize=dd}" }
|
||||
{ "NSRange" "{_NSRange=QQ}" }
|
||||
{ "NSInteger" "q" }
|
||||
{ "NSUInteger" "Q" }
|
||||
{ "CGFloat" "d" }
|
||||
{ NSPoint "{CGPoint=dd}" }
|
||||
{ NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
|
||||
{ NSSize "{CGSize=dd}" }
|
||||
{ NSRange "{_NSRange=QQ}" }
|
||||
{ NSInteger "q" }
|
||||
{ NSUInteger "Q" }
|
||||
{ CGFloat "d" }
|
||||
} ] }
|
||||
} case
|
||||
assoc-union alien>objc-types set-global
|
||||
|
||||
: internal-cocoa-type? ( c-type -- ? )
|
||||
[ "?" = ] [ first CHAR: _ = ] bi or ;
|
||||
|
||||
: warn-c-type ( c-type -- )
|
||||
dup internal-cocoa-type?
|
||||
[ drop ] [ "Warning: no such C type: " write print ] if ;
|
||||
|
||||
: objc-struct-type ( i string -- ctype )
|
||||
[ CHAR: = ] 2keep index-from swap subseq
|
||||
dup c-types get key? [ warn-c-type "void*" ] unless ;
|
||||
objc>struct-types get at* [ drop void* ] unless ;
|
||||
|
||||
ERROR: no-objc-type name ;
|
||||
|
||||
|
|
@ -177,9 +188,9 @@ ERROR: no-objc-type name ;
|
|||
: (parse-objc-type) ( i string -- ctype )
|
||||
[ [ 1 + ] dip ] [ nth ] 2bi {
|
||||
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
|
||||
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
|
||||
{ [ dup CHAR: ^ = ] [ 3drop void* ] }
|
||||
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
||||
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
|
||||
{ [ dup CHAR: [ = ] [ 3drop void* ] }
|
||||
[ 2nip decode-type ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ;
|
|||
IN: cocoa.subclassing
|
||||
|
||||
HELP: define-objc-class
|
||||
{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
|
||||
{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
|
||||
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
|
||||
{ $list
|
||||
{ { $link +name+ } " - a string naming the new class. Required." }
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: compiler.alien
|
|||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
swap return>> large-struct? [ void* prefix ] when ;
|
||||
|
||||
: alien-return ( params -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||
|
|
@ -20,8 +20,7 @@ IN: compiler.alien
|
|||
: parameter-align ( n type -- n delta )
|
||||
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
|
||||
|
||||
: parameter-sizes ( types -- total offsets )
|
||||
#! Compute stack frame locations.
|
||||
: parameter-offsets ( types -- total offsets )
|
||||
[
|
||||
0 [
|
||||
[ parameter-align drop dup , ] keep stack-size +
|
||||
|
|
|
|||
|
|
@ -27,7 +27,9 @@ M: ##call compute-stack-frame*
|
|||
|
||||
M: ##gc compute-stack-frame*
|
||||
frame-required? on
|
||||
stack-frame new swap tagged-values>> length cells >>gc-root-size
|
||||
stack-frame new
|
||||
swap tagged-values>> length cells >>gc-root-size
|
||||
t >>calls-vm?
|
||||
request-stack-frame ;
|
||||
|
||||
M: _spill-area-size compute-stack-frame*
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math
|
|||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
hashtables assocs combinators.short-circuit
|
||||
strings.private accessors compiler.cfg.instructions ;
|
||||
FROM: alien.c-types => int ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
|
|
@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests
|
|||
[ [ t ] loop ]
|
||||
[ [ dup ] loop ]
|
||||
[ [ 2 ] [ 3 throw ] if 4 ]
|
||||
[ "int" f "malloc" { "int" } alien-invoke ]
|
||||
[ "int" { "int" } "cdecl" alien-indirect ]
|
||||
[ "int" { "int" } "cdecl" [ ] alien-callback ]
|
||||
[ int f "malloc" { int } alien-invoke ]
|
||||
[ int { int } "cdecl" alien-indirect ]
|
||||
[ int { int } "cdecl" [ ] alien-callback ]
|
||||
[ swap - + * ]
|
||||
[ swap slot ]
|
||||
[ blahblah ]
|
||||
|
|
@ -213,4 +214,4 @@ IN: compiler.cfg.builder.tests
|
|||
] when
|
||||
|
||||
! Regression. Make sure everything is inlined correctly
|
||||
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
|
||||
|
|
|
|||
|
|
@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ;
|
|||
stack-frame new
|
||||
swap
|
||||
[ return>> return-size >>return ]
|
||||
[ alien-parameters parameter-sizes drop >>params ] bi ;
|
||||
[ alien-parameters parameter-offsets drop >>params ] bi
|
||||
t >>calls-vm? ;
|
||||
|
||||
: alien-node-height ( params -- )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
|
|
|
|||
|
|
@ -163,8 +163,8 @@ IN: compiler.cfg.intrinsics
|
|||
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
|
||||
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
|
||||
|
|
|
|||
|
|
@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
|
|||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.intrinsics.alien
|
||||
specialized-arrays ;
|
||||
FROM: alien.c-types => heap-size char uchar float double ;
|
||||
SPECIALIZED-ARRAYS: float double ;
|
||||
FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
|
||||
SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
|
||||
IN: compiler.cfg.intrinsics.simd
|
||||
|
||||
MACRO: check-elements ( quots -- )
|
||||
|
|
@ -155,28 +155,79 @@ MACRO: if-literals-match ( quots -- )
|
|||
[ ^^not-vector ]
|
||||
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
|
||||
|
||||
:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
|
||||
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
|
||||
{cc,swap} first2 :> swap? :> cc
|
||||
swap?
|
||||
[ src2 src1 rep cc ^^compare-vector ]
|
||||
[ src1 src2 rep cc ^^compare-vector ] if ;
|
||||
|
||||
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
|
||||
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||
rep orig-cc %compare-vector-ccs :> not? :> ccs
|
||||
|
||||
ccs empty?
|
||||
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
||||
[
|
||||
ccs unclip :> first-cc :> rest-ccs
|
||||
src1 src2 rep first-cc (generate-compare-vector) :> first-dst
|
||||
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
|
||||
|
||||
rest-ccs first-dst
|
||||
[ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
|
||||
[ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
|
||||
reduce
|
||||
|
||||
not? [ rep generate-not-vector ] when
|
||||
] if ;
|
||||
|
||||
: sign-bit-mask ( rep -- byte-array )
|
||||
unsign-rep {
|
||||
{ char-16-rep [ uchar-array{
|
||||
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||
HEX: 80 HEX: 80 HEX: 80 HEX: 80
|
||||
} underlying>> ] }
|
||||
{ short-8-rep [ ushort-array{
|
||||
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
|
||||
HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
|
||||
} underlying>> ] }
|
||||
{ int-4-rep [ uint-array{
|
||||
HEX: 8000,0000 HEX: 8000,0000
|
||||
HEX: 8000,0000 HEX: 8000,0000
|
||||
} underlying>> ] }
|
||||
{ longlong-2-rep [ ulonglong-array{
|
||||
HEX: 8000,0000,0000,0000
|
||||
HEX: 8000,0000,0000,0000
|
||||
} underlying>> ] }
|
||||
} case ;
|
||||
|
||||
:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||
orig-cc order-cc {
|
||||
{ cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
|
||||
{ cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
|
||||
{ cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
|
||||
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
|
||||
} case ;
|
||||
|
||||
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
|
||||
{
|
||||
{
|
||||
[ rep orig-cc %compare-vector-reps member? ]
|
||||
[ src1 src2 rep orig-cc (generate-compare-vector) ]
|
||||
}
|
||||
{
|
||||
[ rep %min-vector-reps member? ]
|
||||
[ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
|
||||
}
|
||||
{
|
||||
[ rep unsign-rep orig-cc %compare-vector-reps member? ]
|
||||
[
|
||||
rep sign-bit-mask ^^load-constant :> sign-bits
|
||||
src1 sign-bits rep ^^xor-vector
|
||||
src2 sign-bits rep ^^xor-vector
|
||||
rep unsign-rep orig-cc (generate-compare-vector)
|
||||
]
|
||||
}
|
||||
} cond ;
|
||||
|
||||
:: generate-unpack-vector-head ( src rep -- dst )
|
||||
{
|
||||
{
|
||||
|
|
@ -265,3 +316,17 @@ MACRO: if-literals-match ( quots -- )
|
|||
]
|
||||
} cond ;
|
||||
|
||||
: generate-min-vector ( src1 src2 rep -- dst )
|
||||
dup %min-vector-reps member?
|
||||
[ ^^min-vector ] [
|
||||
[ cc< generate-compare-vector ]
|
||||
[ generate-blend-vector ] 3bi
|
||||
] if ;
|
||||
|
||||
: generate-max-vector ( src1 src2 rep -- dst )
|
||||
dup %max-vector-reps member?
|
||||
[ ^^max-vector ] [
|
||||
[ cc> generate-compare-vector ]
|
||||
[ generate-blend-vector ] 3bi
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: layouts namespaces kernel accessors sequences
|
||||
classes.algebra locals compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
|
||||
USING: layouts namespaces kernel accessors sequences math
|
||||
classes.algebra locals combinators cpu.architecture
|
||||
compiler.tree.propagation.info compiler.cfg.stacks
|
||||
compiler.cfg.hats compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.cfg.utilities
|
||||
compiler.cfg.builder.blocks compiler.constants ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
|
@ -22,11 +23,17 @@ IN: compiler.cfg.intrinsics.slots
|
|||
[ [ second literal>> ] [ first value-tag ] bi ] bi*
|
||||
^^slot-imm ;
|
||||
|
||||
: immediate-slot-offset? ( value-info -- ? )
|
||||
literal>> {
|
||||
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: emit-slot ( node -- )
|
||||
dup node-input-infos
|
||||
dup first value-tag [
|
||||
nip
|
||||
dup second value-info-small-fixnum?
|
||||
dup second immediate-slot-offset?
|
||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||
ds-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
|
@ -61,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
|
|||
dup node-input-infos
|
||||
dup second value-tag [
|
||||
nip
|
||||
dup third value-info-small-fixnum?
|
||||
dup third immediate-slot-offset?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ TUPLE: stack-frame
|
|||
{ return integer }
|
||||
{ total-size integer }
|
||||
{ gc-root-size integer }
|
||||
{ spill-area-size integer } ;
|
||||
{ spill-area-size integer }
|
||||
{ calls-vm? boolean } ;
|
||||
|
||||
! Stack frame utilities
|
||||
: param-base ( -- n )
|
||||
|
|
@ -35,7 +36,9 @@ TUPLE: stack-frame
|
|||
|
||||
: max-stack-frame ( frame1 frame2 -- frame3 )
|
||||
[ stack-frame new ] 2dip
|
||||
{
|
||||
[ [ params>> ] bi@ max >>params ]
|
||||
[ [ return>> ] bi@ max >>return ]
|
||||
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
|
||||
2tri ;
|
||||
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
|
||||
} 2cleave ;
|
||||
|
|
@ -13,11 +13,18 @@ compiler.cfg.value-numbering.graph
|
|||
compiler.cfg.value-numbering.simplify ;
|
||||
IN: compiler.cfg.value-numbering.rewrite
|
||||
|
||||
: vreg-small-constant? ( vreg -- ? )
|
||||
: vreg-immediate-arithmetic? ( vreg -- ? )
|
||||
vreg>expr {
|
||||
[ constant-expr? ]
|
||||
[ value>> fixnum? ]
|
||||
[ value>> small-enough? ]
|
||||
[ value>> immediate-arithmetic? ]
|
||||
} 1&& ;
|
||||
|
||||
: vreg-immediate-bitwise? ( vreg -- ? )
|
||||
vreg>expr {
|
||||
[ constant-expr? ]
|
||||
[ value>> fixnum? ]
|
||||
[ value>> immediate-bitwise? ]
|
||||
} 1&& ;
|
||||
|
||||
! Outputs f to mean no change
|
||||
|
|
@ -174,8 +181,8 @@ M: ##compare-imm-branch rewrite
|
|||
|
||||
M: ##compare-branch rewrite
|
||||
{
|
||||
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
|
||||
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
|
||||
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
|
||||
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
|
||||
{ [ dup self-compare? ] [ rewrite-self-compare-branch ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
|
@ -205,8 +212,8 @@ M: ##compare-branch rewrite
|
|||
|
||||
M: ##compare rewrite
|
||||
{
|
||||
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
|
||||
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
|
||||
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
|
||||
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
|
||||
{ [ dup self-compare? ] [ rewrite-self-compare ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
|
@ -264,6 +271,19 @@ M: ##neg rewrite
|
|||
M: ##not rewrite
|
||||
maybe-unary-constant-fold ;
|
||||
|
||||
: arithmetic-op? ( op -- ? )
|
||||
{
|
||||
##add
|
||||
##add-imm
|
||||
##sub
|
||||
##sub-imm
|
||||
##mul
|
||||
##mul-imm
|
||||
} memq? ;
|
||||
|
||||
: immediate? ( value op -- ? )
|
||||
arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
|
||||
|
||||
: reassociate ( insn op -- insn )
|
||||
[
|
||||
{
|
||||
|
|
@ -273,7 +293,7 @@ M: ##not rewrite
|
|||
[ ]
|
||||
} cleave constant-fold*
|
||||
] dip
|
||||
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
|
||||
2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
|
||||
|
||||
M: ##add-imm rewrite
|
||||
{
|
||||
|
|
@ -283,7 +303,7 @@ M: ##add-imm rewrite
|
|||
} cond ;
|
||||
|
||||
: sub-imm>add-imm ( insn -- insn' )
|
||||
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
|
||||
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
|
||||
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
|
||||
|
||||
M: ##sub-imm rewrite
|
||||
|
|
@ -358,16 +378,20 @@ M: ##sar-imm rewrite
|
|||
[ swap ] when vreg>constant
|
||||
] dip new-insn ; inline
|
||||
|
||||
: vreg-immediate? ( vreg op -- ? )
|
||||
arithmetic-op?
|
||||
[ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
|
||||
|
||||
: rewrite-arithmetic ( insn op -- ? )
|
||||
{
|
||||
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
|
||||
{ [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: rewrite-arithmetic-commutative ( insn op -- ? )
|
||||
{
|
||||
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
|
||||
{ [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
|
||||
{ [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
|
||||
{ [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
|
|
@ -491,3 +515,48 @@ M: ##scalar>vector rewrite
|
|||
M: ##xor-vector rewrite
|
||||
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
|
||||
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
|
||||
|
||||
: vector-not? ( expr -- ? )
|
||||
{
|
||||
[ not-vector-expr? ]
|
||||
[ {
|
||||
[ xor-vector-expr? ]
|
||||
[ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
|
||||
} 1&& ]
|
||||
} 1|| ;
|
||||
|
||||
GENERIC: vector-not-src ( expr -- vreg )
|
||||
M: not-vector-expr vector-not-src src>> vn>vreg ;
|
||||
M: xor-vector-expr vector-not-src
|
||||
dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
|
||||
|
||||
M: ##and-vector rewrite
|
||||
{
|
||||
{ [ dup src1>> vreg>expr vector-not? ] [
|
||||
{
|
||||
[ dst>> ]
|
||||
[ src1>> vreg>expr vector-not-src ]
|
||||
[ src2>> ]
|
||||
[ rep>> ]
|
||||
} cleave \ ##andn-vector new-insn
|
||||
] }
|
||||
{ [ dup src2>> vreg>expr vector-not? ] [
|
||||
{
|
||||
[ dst>> ]
|
||||
[ src2>> vreg>expr vector-not-src ]
|
||||
[ src1>> ]
|
||||
[ rep>> ]
|
||||
} cleave \ ##andn-vector new-insn
|
||||
] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##andn-vector rewrite
|
||||
dup src1>> vreg>expr vector-not? [
|
||||
{
|
||||
[ dst>> ]
|
||||
[ src1>> vreg>expr vector-not-src ]
|
||||
[ src2>> ]
|
||||
[ rep>> ]
|
||||
} cleave \ ##and-vector new-insn
|
||||
] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -1281,6 +1281,128 @@ cell 8 = [
|
|||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! NOT x AND y => x ANDN y
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! x AND NOT y => y ANDN x
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##and-vector f 5 1 4 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##and-vector f 5 1 4 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! NOT x ANDN y => x AND y
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##and-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##andn-vector f 5 4 1 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##and-vector f 5 0 1 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##andn-vector f 5 4 1 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! AND <=> ANDN
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
T{ ##and-vector f 6 0 2 float-4-rep }
|
||||
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##fill-vector f 3 float-4-rep }
|
||||
T{ ##xor-vector f 4 0 3 float-4-rep }
|
||||
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||
T{ ##andn-vector f 6 4 2 float-4-rep }
|
||||
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##andn-vector f 5 0 1 float-4-rep }
|
||||
T{ ##and-vector f 6 0 2 float-4-rep }
|
||||
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##not-vector f 4 0 float-4-rep }
|
||||
T{ ##and-vector f 5 4 1 float-4-rep }
|
||||
T{ ##andn-vector f 6 4 2 float-4-rep }
|
||||
T{ ##or-vector f 7 5 6 float-4-rep }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! branch folding
|
||||
|
||||
: test-branch-folding ( insns -- insns' n )
|
||||
<basic-block>
|
||||
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
|
||||
|
|
|
|||
|
|
@ -333,35 +333,29 @@ M: reg-class reg-class-full?
|
|||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ param-reg ] dip ;
|
||||
|
||||
: (flatten-int-type) ( size -- seq )
|
||||
cell /i "void*" c-type <repetition> ;
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
stack-size cell align cell /i void* c-type <repetition> ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type 1array ;
|
||||
|
||||
M: struct-c-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) % ] keep
|
||||
[ parameter-align cell /i void* c-type <repetition> % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
[ [ parameter-sizes nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
|
||||
[ [ parameter-offsets nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reset-fastcall-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
|
@ -378,10 +372,17 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
[ '[ alloc-parameter _ execute ] ]
|
||||
bi* each-parameter ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
|
||||
|
||||
: prepare-unbox-parameters ( parameters -- offsets types indices )
|
||||
[ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> [
|
||||
%prepare-unbox [ over + ] dip unbox-parameter
|
||||
] reverse-each-parameter drop ;
|
||||
parameters>> swap
|
||||
'[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
|
||||
[ length neg %inc-d ]
|
||||
bi ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
|
|
@ -413,7 +414,7 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
] if ;
|
||||
|
||||
: stdcall-mangle ( symbol params -- symbol )
|
||||
parameters>> parameter-sizes drop number>string "@" glue ;
|
||||
parameters>> parameter-offsets drop number>string "@" glue ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
[ [ function>> dup ] keep stdcall-mangle 2array ]
|
||||
|
|
|
|||
|
|
@ -55,28 +55,22 @@ SYMBOL: compiled
|
|||
|
||||
GENERIC: no-compile? ( word -- ? )
|
||||
|
||||
M: word no-compile? "no-compile" word-prop ;
|
||||
|
||||
M: method-body no-compile? "method-generic" word-prop no-compile? ;
|
||||
|
||||
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
||||
|
||||
M: word no-compile?
|
||||
{
|
||||
[ macro? ]
|
||||
[ inline? ]
|
||||
[ "special" word-prop ]
|
||||
[ "no-compile" word-prop ]
|
||||
} 1|| ;
|
||||
|
||||
: ignore-error? ( word error -- ? )
|
||||
#! Ignore some errors on inline combinators, macros, and special
|
||||
#! words such as 'call'.
|
||||
[
|
||||
{
|
||||
[ macro? ]
|
||||
[ inline? ]
|
||||
[ no-compile? ]
|
||||
[ "special" word-prop ]
|
||||
} 1||
|
||||
] [
|
||||
{
|
||||
[ do-not-compile? ]
|
||||
[ literal-expected? ]
|
||||
} 1||
|
||||
] bi* and ;
|
||||
[ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
|
||||
|
||||
: finish ( word -- )
|
||||
#! Recompile callers if the word's stack effect changed, then
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ CONSTANT: deck-bits 18
|
|||
: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
|
||||
: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
|
||||
: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
|
||||
: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
|
||||
: byte-array-offset ( -- n ) 16 byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
|
||||
: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
|
||||
: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
|
||||
|
|
|
|||
|
|
@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: indirect-test-1 ( ptr -- result )
|
||||
"int" { } "cdecl" alien-indirect ;
|
||||
int { } "cdecl" alien-indirect ;
|
||||
|
||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||
|
||||
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||
|
||||
: indirect-test-1' ( ptr -- )
|
||||
"int" { } "cdecl" alien-indirect drop ;
|
||||
int { } "cdecl" alien-indirect drop ;
|
||||
|
||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||
|
||||
|
|
@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2 ( x y ptr -- result )
|
||||
"int" { "int" "int" } "cdecl" alien-indirect gc ;
|
||||
int { int int } "cdecl" alien-indirect gc ;
|
||||
|
||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||
|
||||
|
|
@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
unit-test
|
||||
|
||||
: indirect-test-3 ( a b c d ptr -- result )
|
||||
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
|
||||
int { int int int int } "stdcall" alien-indirect
|
||||
gc ;
|
||||
|
||||
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||
|
||||
: ffi_test_18 ( w x y z -- int )
|
||||
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
|
||||
int "f-stdcall" "ffi_test_18" { int int int int }
|
||||
alien-invoke gc ;
|
||||
|
||||
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
|
||||
|
||||
: ffi_test_19 ( x y z -- BAR )
|
||||
"BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
|
||||
BAR "f-stdcall" "ffi_test_19" { long long long }
|
||||
alien-invoke gc ;
|
||||
|
||||
[ 11 6 -7 ] [
|
||||
|
|
@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
! Make sure XT doesn't get clobbered in stack frame
|
||||
|
||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
||||
"int"
|
||||
int
|
||||
"f-cdecl" "ffi_test_31"
|
||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
||||
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
|
||||
alien-invoke gc 3 ;
|
||||
|
||||
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
||||
|
||||
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
||||
"float"
|
||||
float
|
||||
"f-cdecl" "ffi_test_31_point_5"
|
||||
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
|
||||
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
|
||||
alien-invoke ;
|
||||
|
||||
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
|
||||
|
|
@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
|
||||
! Test callbacks
|
||||
|
||||
: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
|
||||
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
|
||||
|
||||
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
|
||||
|
||||
[ t ] [ callback-1 alien? ] unit-test
|
||||
|
||||
: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
|
||||
: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
|
||||
|
||||
[ ] [ callback-1 callback_test_1 ] unit-test
|
||||
|
||||
: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
|
||||
[ ] [ callback-2 callback_test_1 ] unit-test
|
||||
|
||||
: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
|
||||
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
|
||||
|
||||
[ t ] [
|
||||
namestack*
|
||||
|
|
@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-4 ( -- callback )
|
||||
"void" { } "cdecl" [ "Hello world" write ] alien-callback
|
||||
void { } "cdecl" [ "Hello world" write ] alien-callback
|
||||
gc ;
|
||||
|
||||
[ "Hello world" ] [
|
||||
|
|
@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-5 ( -- callback )
|
||||
"void" { } "cdecl" [ gc ] alien-callback ;
|
||||
void { } "cdecl" [ gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5 callback_test_1
|
||||
] unit-test
|
||||
|
||||
: callback-5b ( -- callback )
|
||||
"void" { } "cdecl" [ compact-gc ] alien-callback ;
|
||||
void { } "cdecl" [ compact-gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5b callback_test_1
|
||||
] unit-test
|
||||
|
||||
: callback-6 ( -- callback )
|
||||
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
: callback-7 ( -- callback )
|
||||
"void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
|
||||
void { } "cdecl" [ 1000000 sleep ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
[ f ] [ namespace global eq? ] unit-test
|
||||
|
||||
: callback-8 ( -- callback )
|
||||
"void" { } "cdecl" [
|
||||
void { } "cdecl" [
|
||||
[ continue ] callcc0
|
||||
] alien-callback ;
|
||||
|
||||
[ ] [ callback-8 callback_test_1 ] unit-test
|
||||
|
||||
: callback-9 ( -- callback )
|
||||
"int" { "int" "int" "int" } "cdecl" [
|
||||
int { int int int } "cdecl" [
|
||||
+ + 1 +
|
||||
] alien-callback ;
|
||||
|
||||
|
|
@ -440,13 +440,13 @@ STRUCT: double-rect
|
|||
} cleave ;
|
||||
|
||||
: double-rect-callback ( -- alien )
|
||||
"void" { "void*" "void*" "double-rect" } "cdecl"
|
||||
void { void* void* double-rect } "cdecl"
|
||||
[ "example" set-global 2drop ] alien-callback ;
|
||||
|
||||
: double-rect-test ( arg -- arg' )
|
||||
f f rot
|
||||
double-rect-callback
|
||||
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
|
||||
void { void* void* double-rect } "cdecl" alien-indirect
|
||||
"example" get-global ;
|
||||
|
||||
[ 1.0 2.0 3.0 4.0 ]
|
||||
|
|
@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-10 ( -- callback )
|
||||
"test_struct_14" { "double" "double" } "cdecl"
|
||||
test_struct_14 { double double } "cdecl"
|
||||
[
|
||||
test_struct_14 <struct>
|
||||
swap >>x2
|
||||
|
|
@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-10-test ( x1 x2 callback -- result )
|
||||
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
|
||||
test_struct_14 { double double } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-10 callback-10-test
|
||||
|
|
@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
|||
] unit-test
|
||||
|
||||
: callback-11 ( -- callback )
|
||||
"test-struct-12" { "int" "double" } "cdecl"
|
||||
test-struct-12 { int double } "cdecl"
|
||||
[
|
||||
test-struct-12 <struct>
|
||||
swap >>x
|
||||
|
|
@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-11-test ( x1 x2 callback -- result )
|
||||
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
|
||||
test-struct-12 { int double } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1 2.0 ] [
|
||||
1 2.0 callback-11 callback-11-test
|
||||
|
|
@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
|||
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
|
||||
|
||||
: callback-12 ( -- callback )
|
||||
"test_struct_15" { "float" "float" } "cdecl"
|
||||
test_struct_15 { float float } "cdecl"
|
||||
[
|
||||
test_struct_15 <struct>
|
||||
swap >>y
|
||||
|
|
@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-12-test ( x1 x2 callback -- result )
|
||||
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
|
||||
test_struct_15 { float float } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
|
||||
|
|
@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
|||
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
|
||||
|
||||
: callback-13 ( -- callback )
|
||||
"test_struct_16" { "float" "int" } "cdecl"
|
||||
test_struct_16 { float int } "cdecl"
|
||||
[
|
||||
test_struct_16 <struct>
|
||||
swap >>a
|
||||
|
|
@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
|||
] alien-callback ;
|
||||
|
||||
: callback-13-test ( x1 x2 callback -- result )
|
||||
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
|
||||
test_struct_16 { float int } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2 ] [
|
||||
1.0 2 callback-13 callback-13-test
|
||||
|
|
|
|||
|
|
@ -270,8 +270,8 @@ TUPLE: id obj ;
|
|||
{ float } declare dup 0 =
|
||||
[ drop 1 ] [
|
||||
dup 0 >=
|
||||
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
||||
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
|
||||
[ 2 double "libm" "pow" { double double } alien-invoke ]
|
||||
[ -0.5 double "libm" "pow" { double double } alien-invoke ]
|
||||
if
|
||||
] if ;
|
||||
|
||||
|
|
@ -475,4 +475,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
|
|||
[ 2 0 ] [
|
||||
1 1
|
||||
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -87,14 +87,17 @@ IN: compiler.tests.intrinsics
|
|||
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
|
||||
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
|
||||
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
|
||||
[ -16 ] [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
|
||||
|
||||
[ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
|
||||
[ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
|
||||
[ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
|
||||
|
||||
[ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
|
||||
[ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
|
||||
[ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
|
||||
[ 15 ] [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
|
||||
[ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ IN: compiler.tests.low-level-ir
|
|||
V{
|
||||
T{ ##load-reference f 1 B{ 31 67 52 } }
|
||||
T{ ##unbox-any-c-ptr f 0 1 2 }
|
||||
T{ ##alien-unsigned-1 f 0 0 }
|
||||
T{ ##alien-unsigned-1 f 0 0 0 }
|
||||
T{ ##shl-imm f 0 0 3 }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ;
|
|||
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
|
||||
[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
|
||||
|
||||
[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
|
||||
|
||||
! Not sure if I want to fix this...
|
||||
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
USING: compiler compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings alien
|
||||
arrays memory vocabs parser eval ;
|
||||
arrays memory vocabs parser eval quotations compiler.errors
|
||||
definitions ;
|
||||
IN: compiler.tests.simple
|
||||
|
||||
! Test empty word
|
||||
|
|
@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
|
||||
] unit-test
|
||||
] times
|
||||
|
||||
! This should not compile
|
||||
GENERIC: bad-effect-test ( a -- )
|
||||
M: quotation bad-effect-test call ; inline
|
||||
: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
|
||||
|
||||
[ bad-effect-test* ] [ not-compiled? ] must-fail-with
|
||||
|
||||
! Don't want compiler error to stick around
|
||||
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
|||
|
|
@ -340,18 +340,3 @@ SYMBOL: value-infos
|
|||
dup in-d>> last node-value-info
|
||||
literal>> first immutable-tuple-class?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: value-info-small-fixnum? ( value-info -- ? )
|
||||
literal>> {
|
||||
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: value-info-small-tagged? ( value-info -- ? )
|
||||
dup literal?>> [
|
||||
literal>> {
|
||||
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
|
||||
{ [ dup not ] [ drop t ] }
|
||||
[ drop f ]
|
||||
} cond
|
||||
] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -140,8 +140,19 @@ IN: compiler.tree.propagation.known-words
|
|||
'[ _ _ 2bi ] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
|
||||
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
|
||||
: shift-op-class ( info1 info2 -- newclass )
|
||||
[ class>> ] bi@
|
||||
2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
|
||||
|
||||
: shift-op ( word interval-quot post-proc-quot -- )
|
||||
'[
|
||||
[ shift-op-class ] [ _ binary-op-interval ] 2bi
|
||||
@
|
||||
<class/interval-info>
|
||||
] "outputs" set-word-prop ;
|
||||
|
||||
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
|
||||
\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
|
||||
|
||||
\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
|
||||
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
|
||||
|
|
|
|||
|
|
@ -407,10 +407,18 @@ IN: compiler.tree.propagation.tests
|
|||
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
[ V{ integer } ] [
|
||||
[ { fixnum } declare 1 swap 31 bitand shift ]
|
||||
|
|
@ -900,9 +908,20 @@ M: tuple-with-read-only-slot clone
|
|||
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
|
||||
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
|
||||
|
||||
! bitand identities
|
||||
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
|
||||
[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
|
||||
[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
|
||||
[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
|
||||
[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test
|
||||
[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
|
||||
[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test
|
||||
[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
|
||||
[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
|
||||
|
||||
! Could be bignum not integer but who cares
|
||||
[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
|
||||
|
|
|
|||
|
|
@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms
|
|||
: positive-fixnum? ( obj -- ? )
|
||||
{ [ fixnum? ] [ 0 >= ] } 1&& ;
|
||||
|
||||
: simplify-bitand? ( value -- ? )
|
||||
value-info literal>> positive-fixnum? ;
|
||||
: simplify-bitand? ( value1 value2 -- ? )
|
||||
[ literal>> positive-fixnum? ]
|
||||
[ class>> fixnum swap class<= ]
|
||||
bi* and ;
|
||||
|
||||
: all-ones? ( int -- ? )
|
||||
dup 1 + bitand zero? ; inline
|
||||
: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
|
||||
|
||||
: redundant-bitand? ( var 111... -- ? )
|
||||
[ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
|
||||
: redundant-bitand? ( value1 value2 -- ? )
|
||||
[ interval>> ] [ literal>> ] bi* {
|
||||
[ nip integer? ]
|
||||
[ nip all-ones? ]
|
||||
[ 0 swap [a,b] interval-subset? ]
|
||||
} 2&& ;
|
||||
|
||||
: (zero-bitand?) ( value-info value-info' -- ? )
|
||||
: zero-bitand? ( value1 value2 -- ? )
|
||||
[ interval>> ] [ literal>> ] bi* {
|
||||
[ nip integer? ]
|
||||
[ nip bitnot all-ones? ]
|
||||
[ 0 swap bitnot [a,b] interval-subset? ]
|
||||
} 2&& ;
|
||||
|
||||
: zero-bitand? ( var1 var2 -- ? )
|
||||
[ value-info ] bi@
|
||||
{ [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
@ -73,35 +70,45 @@ IN: compiler.tree.propagation.transforms
|
|||
bitand
|
||||
} [
|
||||
[
|
||||
{
|
||||
in-d>> first2 [ value-info ] bi@ {
|
||||
{
|
||||
[ dup in-d>> first2 zero-bitand? ]
|
||||
[ drop [ 2drop 0 ] ]
|
||||
[ 2dup zero-bitand? ]
|
||||
[ 2drop [ 2drop 0 ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> first2 redundant-bitand? ]
|
||||
[ drop [ drop ] ]
|
||||
[ 2dup swap zero-bitand? ]
|
||||
[ 2drop [ 2drop 0 ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> first2 swap redundant-bitand? ]
|
||||
[ drop [ nip ] ]
|
||||
[ 2dup redundant-bitand? ]
|
||||
[ 2drop [ drop ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> first simplify-bitand? ]
|
||||
[ drop [ >fixnum fixnum-bitand ] ]
|
||||
[ 2dup swap redundant-bitand? ]
|
||||
[ 2drop [ nip ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> second simplify-bitand? ]
|
||||
[ drop [ [ >fixnum ] dip fixnum-bitand ] ]
|
||||
[ 2dup simplify-bitand? ]
|
||||
[ 2drop [ >fixnum fixnum-bitand ] ]
|
||||
}
|
||||
[ drop f ]
|
||||
{
|
||||
[ 2dup swap simplify-bitand? ]
|
||||
[ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
|
||||
}
|
||||
[ 2drop f ]
|
||||
} cond
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
! Speeds up 2^
|
||||
: 2^? ( #call -- ? )
|
||||
in-d>> first2 [ value-info ] bi@
|
||||
[ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
|
||||
[ class>> fixnum class<= ]
|
||||
bi* and ;
|
||||
|
||||
\ shift [
|
||||
in-d>> first value-info literal>> 1 = [
|
||||
2^? [
|
||||
cell-bits tag-bits get - 1 -
|
||||
'[
|
||||
>fixnum dup 0 < [ 2drop 0 ] [
|
||||
|
|
|
|||
|
|
@ -18,9 +18,10 @@ HELP: mailbox-put
|
|||
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
|
||||
|
||||
HELP: block-unless-pred
|
||||
{ $values { "pred" { $quotation "( obj -- ? )" } }
|
||||
{ $values
|
||||
{ "mailbox" mailbox }
|
||||
{ "timeout" "a " { $link duration } " or " { $link f } }
|
||||
{ "pred" { $quotation "( obj -- ? )" } }
|
||||
}
|
||||
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,8 +36,8 @@ STRUCT: FSEventStreamContext
|
|||
{ release void* }
|
||||
{ copyDescription void* } ;
|
||||
|
||||
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
|
||||
TYPEDEF: void* FSEventStreamCallback
|
||||
! callback(
|
||||
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
|
||||
|
||||
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
|
||||
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ PRIVATE>
|
|||
[ fds>> [ enable-all-callbacks ] each ] bi ;
|
||||
|
||||
: timer-callback ( -- callback )
|
||||
"void" { "CFRunLoopTimerRef" "void*" } "cdecl"
|
||||
void { CFRunLoopTimerRef void* } "cdecl"
|
||||
[ 2drop reset-run-loop yield ] alien-callback ;
|
||||
|
||||
: init-thread-timer ( -- )
|
||||
|
|
|
|||
|
|
@ -440,9 +440,13 @@ M: reg-class param-reg param-regs nth ;
|
|||
|
||||
M: stack-params param-reg drop ;
|
||||
|
||||
! Is this integer small enough to appear in value template
|
||||
! slots?
|
||||
HOOK: small-enough? cpu ( n -- ? )
|
||||
! Is this integer small enough to be an immediate operand for
|
||||
! %add-imm, %sub-imm, and %mul-imm?
|
||||
HOOK: immediate-arithmetic? cpu ( n -- ? )
|
||||
|
||||
! Is this integer small enough to be an immediate operand for
|
||||
! %and-imm, %or-imm, and %xor-imm?
|
||||
HOOK: immediate-bitwise? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
|
@ -459,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? )
|
|||
! If t, all int parameters are shadowed by dummy FP parameters
|
||||
HOOK: dummy-fp-params? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
HOOK: %prepare-unbox cpu ( n -- )
|
||||
|
||||
HOOK: %unbox cpu ( n rep func -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -374,7 +374,7 @@ M: ppc %set-alien-double -rot STFD ;
|
|||
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
|
||||
|
||||
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
|
||||
scratch-reg allot-ptr n 8 align ADDI
|
||||
scratch-reg allot-ptr n data-alignment get align ADDI
|
||||
scratch-reg nursery-ptr 0 STW ;
|
||||
|
||||
:: store-header ( dst class -- )
|
||||
|
|
@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- )
|
|||
M:: ppc %load-param-reg ( stack reg rep -- )
|
||||
reg stack local@ rep load-from-frame ;
|
||||
|
||||
M: ppc %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup cell SUBI ;
|
||||
M: ppc %prepare-unbox ( n -- )
|
||||
[ 3 ] dip <ds-loc> loc>operand LWZ ;
|
||||
|
||||
M: ppc %unbox ( n rep func -- )
|
||||
! Value must be in r3
|
||||
|
|
@ -681,7 +679,9 @@ M: ppc %callback-value ( ctype -- )
|
|||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
|
||||
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? )
|
||||
c-type return-in-registers?>> ;
|
||||
|
|
|
|||
|
|
@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ;
|
|||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 temp-reg ECX ;
|
||||
|
||||
: local@ ( n -- op )
|
||||
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
|
||||
|
||||
M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
|
||||
|
||||
M: x86.32 %mark-card
|
||||
drop HEX: ffffffff [+] card-mark <byte> MOV
|
||||
building get pop
|
||||
|
|
@ -57,12 +62,12 @@ M:: x86.32 %dispatch ( src temp -- )
|
|||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
M: x86.32 reserved-stack-space 4 cells ;
|
||||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
: push-vm-ptr ( -- )
|
||||
0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
|
||||
: save-vm-ptr ( n -- )
|
||||
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
@ -72,44 +77,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: float-regs param-regs drop { } ;
|
||||
|
||||
GENERIC: push-return-reg ( rep -- )
|
||||
GENERIC: load-return-reg ( n rep -- )
|
||||
GENERIC: store-return-reg ( n rep -- )
|
||||
GENERIC: load-return-reg ( src rep -- )
|
||||
GENERIC: store-return-reg ( dst rep -- )
|
||||
|
||||
M: int-rep push-return-reg drop EAX PUSH ;
|
||||
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
|
||||
M: int-rep store-return-reg drop stack@ EAX MOV ;
|
||||
M: int-rep load-return-reg drop EAX swap MOV ;
|
||||
M: int-rep store-return-reg drop EAX MOV ;
|
||||
|
||||
M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
|
||||
M: float-rep load-return-reg drop next-stack@ FLDS ;
|
||||
M: float-rep store-return-reg drop stack@ FSTPS ;
|
||||
M: float-rep load-return-reg drop FLDS ;
|
||||
M: float-rep store-return-reg drop FSTPS ;
|
||||
|
||||
M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
|
||||
M: double-rep load-return-reg drop next-stack@ FLDL ;
|
||||
M: double-rep store-return-reg drop stack@ FSTPL ;
|
||||
|
||||
: align-sub ( n -- )
|
||||
[ align-stack ] keep - decr-stack-reg ;
|
||||
|
||||
: align-add ( n -- )
|
||||
align-stack incr-stack-reg ;
|
||||
|
||||
: with-aligned-stack ( n quot -- )
|
||||
'[ align-sub @ ] [ align-add ] bi ; inline
|
||||
M: double-rep load-return-reg drop FLDL ;
|
||||
M: double-rep store-return-reg drop FSTPL ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
0 PUSH rc-absolute-cell rel-this
|
||||
3 cells - decr-stack-reg ;
|
||||
|
||||
M: x86.32 %load-param-reg 3drop ;
|
||||
M: x86.32 %load-param-reg
|
||||
stack-params assert=
|
||||
[ [ EAX ] dip local@ MOV ] dip
|
||||
stack@ EAX MOV ;
|
||||
|
||||
M: x86.32 %save-param-reg 3drop ;
|
||||
|
||||
|
|
@ -118,16 +113,14 @@ M: x86.32 %save-param-reg 3drop ;
|
|||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ load-return-reg ] [ 2drop ] if ;
|
||||
over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( n rep func -- )
|
||||
n rep (%box)
|
||||
rep rep-size cell + [
|
||||
push-vm-ptr
|
||||
rep push-return-reg
|
||||
func f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
rep rep-size save-vm-ptr
|
||||
0 stack@ rep store-return-reg
|
||||
func f %alien-invoke ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
[
|
||||
EDX over next-stack@ MOV
|
||||
|
|
@ -136,56 +129,39 @@ M:: x86.32 %box ( n rep func -- )
|
|||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
[ (%box-long-long) ] dip
|
||||
12 [
|
||||
push-vm-ptr
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
EDX n struct-return@ LEA
|
||||
12 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ c-type heap-size MOV
|
||||
0 stack@ EDX MOV
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
EAX f struct-return@ LEA
|
||||
! Store it as the first parameter
|
||||
0 stack@ EAX MOV ;
|
||||
0 local@ EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
16 [
|
||||
push-vm-ptr
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
12 save-vm-ptr
|
||||
8 stack@ swap heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"box_small_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
EAX swap ds-reg reg-stack MOV ;
|
||||
|
||||
: call-unbox-func ( func -- )
|
||||
8 [
|
||||
! push the vm ptr as an argument
|
||||
push-vm-ptr
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unbox ( n rep func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
|
|
@ -194,37 +170,33 @@ M: x86.32 %unbox ( n rep func -- )
|
|||
#! a parameter to a C function about to be called.
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
[ local@ EAX MOV ]
|
||||
[ 4 + local@ EDX MOV ] bi
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
|
|
@ -236,63 +208,46 @@ M: x86 %unbox-small-struct ( size -- )
|
|||
M:: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
! Alien must be in EAX.
|
||||
! Compute destination address
|
||||
EDX n stack@ LEA
|
||||
16 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
EDX n local@ LEA
|
||||
12 save-vm-ptr
|
||||
8 stack@ c-type heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %nest-stacks ( -- )
|
||||
! Save current frame. See comment in vm/contexts.hpp
|
||||
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"nest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unnest-stacks ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
0 save-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
"unbox_alien" f %alien-invoke
|
||||
] with-aligned-stack
|
||||
0 save-vm-ptr
|
||||
"unbox_alien" f %alien-invoke
|
||||
EBP EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
EBP CALL ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
! Fastcall
|
||||
param-reg-1 swap %load-reference
|
||||
param-reg-2 %mov-vm-ptr
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack in non-volatile register
|
||||
%prepare-unbox
|
||||
EAX PUSH
|
||||
push-vm-ptr
|
||||
0 %prepare-unbox
|
||||
4 stack@ EAX MOV
|
||||
0 save-vm-ptr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Place top of data stack in EAX
|
||||
temp-reg POP
|
||||
EAX POP
|
||||
! Restore C stack
|
||||
ESP 12 ADD
|
||||
! Place former top of data stack back in EAX
|
||||
EAX 4 stack@ MOV
|
||||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
|
|
@ -357,17 +312,11 @@ M: x86.32 %callback-return ( n -- )
|
|||
} cond RET ;
|
||||
|
||||
M:: x86.32 %call-gc ( gc-root-count temp -- )
|
||||
temp gc-root-base param@ LEA
|
||||
12 [
|
||||
! Pass the VM ptr as the third parameter
|
||||
push-vm-ptr
|
||||
! Pass number of roots as second parameter
|
||||
gc-root-count PUSH
|
||||
! Pass pointer to start of GC roots as first parameter
|
||||
temp PUSH
|
||||
! Call GC
|
||||
"inline_gc" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
temp gc-root-base special@ LEA
|
||||
8 save-vm-ptr
|
||||
4 stack@ gc-root-count MOV
|
||||
0 stack@ temp MOV
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: x86.32 dummy-stack-params? f ;
|
||||
|
||||
|
|
@ -375,10 +324,13 @@ M: x86.32 dummy-int-params? f ;
|
|||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
! Dreadful
|
||||
M: object flatten-value-type (flatten-int-type) ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
cell longlong c-type (>>align)
|
||||
cell ulonglong c-type (>>align)
|
||||
4 double c-type (>>align)
|
||||
] unless
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
|
|
@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
|
|||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
|
||||
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
|
||||
M: x86.64 extra-stack-space drop 0 ;
|
||||
|
||||
M: x86.64 machine-registers
|
||||
{
|
||||
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
|
||||
|
|
@ -17,9 +33,13 @@ M: x86.64 machine-registers
|
|||
} }
|
||||
} ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg 0 MOV rc-absolute-cell rel-this
|
||||
dup PUSH
|
||||
temp-reg PUSH
|
||||
stack-reg swap 3 cells - SUB ;
|
||||
|
||||
: load-cards-offset ( dst -- )
|
||||
0 MOV rc-absolute-cell rel-cards-offset ;
|
||||
|
|
@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- )
|
|||
[ align-code ]
|
||||
bi ;
|
||||
|
||||
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
|
||||
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg 0 MOV rc-absolute-cell rel-this
|
||||
dup PUSH
|
||||
temp-reg PUSH
|
||||
stack-reg swap 3 cells - SUB ;
|
||||
|
||||
M: stack-params copy-register*
|
||||
drop
|
||||
{
|
||||
|
|
@ -84,10 +88,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ;
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
param-reg-1 R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
M: x86.64 %prepare-unbox ( n -- )
|
||||
param-reg-1 swap ds-reg reg-stack MOV ;
|
||||
|
||||
M:: x86.64 %unbox ( n rep func -- )
|
||||
param-reg-2 %mov-vm-ptr
|
||||
|
|
@ -217,9 +219,7 @@ M: x86.64 %alien-callback ( quot -- )
|
|||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
! Save top of data stack
|
||||
0 %prepare-unbox
|
||||
RSP 8 SUB
|
||||
param-reg-1 PUSH
|
||||
param-reg-1 %mov-vm-ptr
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ M: int-regs param-regs
|
|||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 0 ;
|
||||
M: x86.64 reserved-stack-space 0 ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
! The ABI for passing structs by value is pretty great
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
|||
|
||||
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
M: x86.64 reserved-stack-space 4 cells ;
|
||||
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size { 1 2 4 8 } member? ;
|
||||
|
|
|
|||
|
|
@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ;
|
|||
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
||||
HOOK: reserved-area-size cpu ( -- n )
|
||||
HOOK: reserved-stack-space cpu ( -- n )
|
||||
|
||||
HOOK: extra-stack-space cpu ( stack-frame -- n )
|
||||
|
||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: param@ ( n -- op ) reserved-area-size + stack@ ;
|
||||
: special@ ( n -- op )
|
||||
stack-frame get extra-stack-space +
|
||||
reserved-stack-space +
|
||||
stack@ ;
|
||||
|
||||
: spill@ ( n -- op ) spill-offset param@ ;
|
||||
: spill@ ( n -- op ) spill-offset special@ ;
|
||||
|
||||
: gc-root@ ( n -- op ) gc-root-offset param@ ;
|
||||
: gc-root@ ( n -- op ) gc-root-offset special@ ;
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||
|
|
@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n )
|
|||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
|
||||
M: x86 stack-frame-size ( stack-frame -- i )
|
||||
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
|
||||
[ (stack-frame-size) ]
|
||||
[ extra-stack-space ] bi +
|
||||
reserved-stack-space +
|
||||
3 cells +
|
||||
align-stack ;
|
||||
|
||||
! Must be a volatile register not used for parameter passing, for safe
|
||||
! use in calls in and out of C
|
||||
|
|
@ -379,7 +388,7 @@ M: x86 %vm-field-ptr ( dst field -- )
|
|||
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
|
||||
|
||||
: inc-allot-ptr ( nursery-ptr n -- )
|
||||
[ [] ] dip 8 align ADD ;
|
||||
[ [] ] dip data-alignment get align ADD ;
|
||||
|
||||
: store-header ( temp class -- )
|
||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
|
@ -879,12 +888,12 @@ M: x86 %compare-vector ( dst src1 src2 rep cc -- )
|
|||
{
|
||||
{ sse? { float-4-rep } }
|
||||
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
|
||||
{ sse4.1? { longlong-2-rep } }
|
||||
{ sse4.2? { longlong-2-rep } }
|
||||
} available-reps ;
|
||||
|
||||
M: x86 %compare-vector-reps
|
||||
{
|
||||
{ [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] }
|
||||
{ [ dup { cc= cc/= cc/<>= cc<>= } memq? ] [ drop %compare-vector-eq-reps ] }
|
||||
[ drop %compare-vector-ord-reps ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -1089,7 +1098,7 @@ M: x86 %min-vector ( dst src1 src2 rep -- )
|
|||
M: x86 %min-vector-reps
|
||||
{
|
||||
{ sse? { float-4-rep } }
|
||||
{ sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
|
||||
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
|
||||
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
|
||||
} available-reps ;
|
||||
|
||||
|
|
@ -1109,7 +1118,7 @@ M: x86 %max-vector ( dst src1 src2 rep -- )
|
|||
M: x86 %max-vector-reps
|
||||
{
|
||||
{ sse? { float-4-rep } }
|
||||
{ sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
|
||||
{ sse2? { uchar-16-rep short-8-rep double-2-rep } }
|
||||
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
|
||||
} available-reps ;
|
||||
|
||||
|
|
@ -1337,7 +1346,10 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
|
|||
|
||||
M: x86 value-struct? drop t ;
|
||||
|
||||
M: x86 small-enough? ( n -- ? )
|
||||
M: x86 immediate-arithmetic? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
M: x86 immediate-bitwise? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
: next-stack@ ( n -- operand )
|
||||
|
|
|
|||
|
|
@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
|
|||
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
|
||||
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
|
||||
|
||||
TYPEDEF: void sqlite3
|
||||
TYPEDEF: void sqlite3_stmt
|
||||
TYPEDEF: void* sqlite3*
|
||||
TYPEDEF: void* sqlite3_stmt*
|
||||
TYPEDEF: longlong sqlite3_int64
|
||||
TYPEDEF: ulonglong sqlite3_uint64
|
||||
|
||||
|
|
@ -120,8 +120,8 @@ FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
|||
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
|
||||
"int" "sqlite" "sqlite3_bind_int64"
|
||||
{ "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
|
||||
int "sqlite" "sqlite3_bind_int64"
|
||||
{ sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
|
||||
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
|
||||
|
|
@ -134,8 +134,8 @@ FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
|||
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
||||
! Bind the same function as above, but for unsigned 64bit integers
|
||||
: sqlite3-column-uint64 ( pStmt col -- uint64 )
|
||||
"sqlite3_uint64" "sqlite" "sqlite3_column_int64"
|
||||
{ "sqlite3_stmt*" "int" } alien-invoke ;
|
||||
sqlite3_uint64 "sqlite" "sqlite3_column_int64"
|
||||
{ sqlite3_stmt* int } alien-invoke ;
|
||||
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
|
|||
|
|
@ -8,19 +8,22 @@ continuations.private combinators generic.math classes.builtin classes
|
|||
compiler.units generic.standard generic.single vocabs init
|
||||
kernel.private io.encodings accessors math.order destructors
|
||||
source-files parser classes.tuple.parser effects.parser lexer
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser
|
||||
source-files.errors ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
GENERIC: error-help ( error -- topic )
|
||||
|
||||
M: object error. . ;
|
||||
|
||||
M: object error-help drop f ;
|
||||
|
||||
M: tuple error-help class ;
|
||||
|
||||
M: source-file-error error-help error>> error-help ;
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
||||
M: object error. . ;
|
||||
|
||||
M: string error. print ;
|
||||
|
||||
: :s ( -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,42 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: debugger io prettyprint sequences system ;
|
||||
USING: assocs debugger io kernel literals math.parser namespaces
|
||||
prettyprint sequences system windows.kernel32 ;
|
||||
IN: debugger.windows
|
||||
|
||||
M: windows signal-error. "Windows exception #" write third .h ;
|
||||
CONSTANT: seh-names
|
||||
H{
|
||||
{ $ STATUS_GUARD_PAGE_VIOLATION "STATUS_GUARD_PAGE_VIOLATION" }
|
||||
{ $ STATUS_DATATYPE_MISALIGNMENT "STATUS_DATATYPE_MISALIGNMENT" }
|
||||
{ $ STATUS_BREAKPOINT "STATUS_BREAKPOINT" }
|
||||
{ $ STATUS_SINGLE_STEP "STATUS_SINGLE_STEP" }
|
||||
{ $ STATUS_ACCESS_VIOLATION "STATUS_ACCESS_VIOLATION" }
|
||||
{ $ STATUS_IN_PAGE_ERROR "STATUS_IN_PAGE_ERROR" }
|
||||
{ $ STATUS_INVALID_HANDLE "STATUS_INVALID_HANDLE" }
|
||||
{ $ STATUS_NO_MEMORY "STATUS_NO_MEMORY" }
|
||||
{ $ STATUS_ILLEGAL_INSTRUCTION "STATUS_ILLEGAL_INSTRUCTION" }
|
||||
{ $ STATUS_NONCONTINUABLE_EXCEPTION "STATUS_NONCONTINUABLE_EXCEPTION" }
|
||||
{ $ STATUS_INVALID_DISPOSITION "STATUS_INVALID_DISPOSITION" }
|
||||
{ $ STATUS_ARRAY_BOUNDS_EXCEEDED "STATUS_ARRAY_BOUNDS_EXCEEDED" }
|
||||
{ $ STATUS_FLOAT_DENORMAL_OPERAND "STATUS_FLOAT_DENORMAL_OPERAND" }
|
||||
{ $ STATUS_FLOAT_DIVIDE_BY_ZERO "STATUS_FLOAT_DIVIDE_BY_ZERO" }
|
||||
{ $ STATUS_FLOAT_INEXACT_RESULT "STATUS_FLOAT_INEXACT_RESULT" }
|
||||
{ $ STATUS_FLOAT_INVALID_OPERATION "STATUS_FLOAT_INVALID_OPERATION" }
|
||||
{ $ STATUS_FLOAT_OVERFLOW "STATUS_FLOAT_OVERFLOW" }
|
||||
{ $ STATUS_FLOAT_STACK_CHECK "STATUS_FLOAT_STACK_CHECK" }
|
||||
{ $ STATUS_FLOAT_UNDERFLOW "STATUS_FLOAT_UNDERFLOW" }
|
||||
{ $ STATUS_INTEGER_DIVIDE_BY_ZERO "STATUS_INTEGER_DIVIDE_BY_ZERO" }
|
||||
{ $ STATUS_INTEGER_OVERFLOW "STATUS_INTEGER_OVERFLOW" }
|
||||
{ $ STATUS_PRIVILEGED_INSTRUCTION "STATUS_PRIVILEGED_INSTRUCTION" }
|
||||
{ $ STATUS_STACK_OVERFLOW "STATUS_STACK_OVERFLOW" }
|
||||
{ $ STATUS_CONTROL_C_EXIT "STATUS_CONTROL_C_EXIT" }
|
||||
{ $ STATUS_FLOAT_MULTIPLE_FAULTS "STATUS_FLOAT_MULTIPLE_FAULTS" }
|
||||
{ $ STATUS_FLOAT_MULTIPLE_TRAPS "STATUS_FLOAT_MULTIPLE_TRAPS" }
|
||||
}
|
||||
|
||||
: seh-name. ( n -- )
|
||||
seh-names at [ " (" ")" surround write ] when* ;
|
||||
|
||||
M: windows signal-error.
|
||||
"Windows exception 0x" write
|
||||
third [ >hex write ] [ seh-name. ] bi nl ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.syntax help.markup delegate.private ;
|
|||
IN: delegate
|
||||
|
||||
HELP: define-protocol
|
||||
{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
|
||||
{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } }
|
||||
{ $description "Defines a symbol as a protocol." }
|
||||
{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,11 +12,11 @@ HELP: +line
|
|||
{ $description "Adds an integer to the line number of a line/column pair." } ;
|
||||
|
||||
HELP: =col
|
||||
{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
|
||||
{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
|
||||
{ $description "Sets the column number of a line/column pair." } ;
|
||||
|
||||
HELP: =line
|
||||
{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
|
||||
{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
|
||||
{ $description "Sets the line number of a line/column pair." } ;
|
||||
|
||||
HELP: lines-equal?
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting parser parser.notes compiler.units kernel namespaces
|
||||
debugger io.streams.string fry combinators effects.parser ;
|
||||
USING: splitting parser parser.notes compiler.units kernel
|
||||
namespaces debugger io.streams.string fry combinators
|
||||
effects.parser continuations ;
|
||||
IN: eval
|
||||
|
||||
: parse-string ( str -- quot )
|
||||
|
|
@ -19,7 +20,7 @@ SYNTAX: eval( \ eval parse-call( ;
|
|||
[
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
'[ _ (( -- )) (eval) ] try
|
||||
'[ _ (( -- )) (eval) ] [ print-error ] recover
|
||||
] with-string-writer ;
|
||||
|
||||
: eval>string ( str -- output )
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ HELP: realm
|
|||
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
|
||||
|
||||
HELP: uchange
|
||||
{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
|
||||
{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } }
|
||||
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
|
||||
|
||||
HELP: uget
|
||||
|
|
|
|||
|
|
@ -266,26 +266,6 @@ HELP: spread-curry
|
|||
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }
|
||||
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;
|
||||
|
||||
HELP: neach
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
|
||||
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: nmap
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
|
||||
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: nmap-as
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
|
||||
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: mnmap
|
||||
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
|
||||
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
|
||||
|
||||
HELP: mnmap-as
|
||||
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } }
|
||||
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
|
||||
|
||||
HELP: mnswap
|
||||
{ $values { "m" integer } { "n" integer } }
|
||||
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
|
||||
|
|
@ -401,11 +381,6 @@ ARTICLE: "combinator-generalizations" "Generalized combinators"
|
|||
apply-curry
|
||||
cleave-curry
|
||||
spread-curry
|
||||
neach
|
||||
nmap
|
||||
nmap-as
|
||||
mnmap
|
||||
mnmap-as
|
||||
} ;
|
||||
|
||||
ARTICLE: "other-generalizations" "Additional generalizations"
|
||||
|
|
@ -424,6 +399,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
|||
"shuffle-generalizations"
|
||||
"combinator-generalizations"
|
||||
"other-generalizations"
|
||||
} ;
|
||||
}
|
||||
"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
|
|||
|
|
@ -82,108 +82,6 @@ IN: generalizations.tests
|
|||
|
||||
[ '[ number>string _ append ] 4 napply ] must-infer
|
||||
|
||||
: neach-test ( a b c d -- )
|
||||
[ 4 nappend print ] 4 neach ;
|
||||
: nmap-test ( a b c d -- e )
|
||||
[ 4 nappend ] 4 nmap ;
|
||||
: nmap-as-test ( a b c d -- e )
|
||||
[ 4 nappend ] [ ] 4 nmap-as ;
|
||||
: mnmap-3-test ( a b c d -- e f g )
|
||||
[ append ] 4 3 mnmap ;
|
||||
: mnmap-2-test ( a b c d -- e f )
|
||||
[ [ append ] 2bi@ ] 4 2 mnmap ;
|
||||
: mnmap-as-test ( a b c d -- e f )
|
||||
[ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
|
||||
: mnmap-1-test ( a b c d -- e )
|
||||
[ 4 nappend ] 4 1 mnmap ;
|
||||
: mnmap-0-test ( a b c d -- )
|
||||
[ 4 nappend print ] 4 0 mnmap ;
|
||||
|
||||
[ """A1a!
|
||||
B2b@
|
||||
C3c#
|
||||
D4d$
|
||||
""" ] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
[ neach-test ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
nmap-test
|
||||
] unit-test
|
||||
|
||||
[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
nmap-as-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a!" "b@" "c#" "d$" }
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-3-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A1" "B2" "C3" "D4" }
|
||||
{ "a!" "b@" "c#" "d$" }
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-2-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A1" "B2" "C3" "D4" }
|
||||
[ "a!" "b@" "c#" "d$" ]
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-as-test
|
||||
] unit-test
|
||||
|
||||
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-1-test
|
||||
] unit-test
|
||||
|
||||
[ """A1a!
|
||||
B2b@
|
||||
C3c#
|
||||
D4d$
|
||||
""" ] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
[ mnmap-0-test ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ 6 8 10 12 ] [
|
||||
1 2 3 4
|
||||
5 6 7 8 [ + ] 4 apply-curry 4 spread*
|
||||
|
|
|
|||
|
|
@ -142,57 +142,3 @@ MACRO: nbi-curry ( n -- )
|
|||
MACRO: nspin ( n -- )
|
||||
[ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
|
||||
|
||||
MACRO: nmin-length ( n -- )
|
||||
dup 1 - [ min ] n*quot
|
||||
'[ [ length ] _ napply @ ] ;
|
||||
|
||||
: nnth-unsafe ( n ...seq n -- )
|
||||
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
|
||||
MACRO: nset-nth-unsafe ( n -- )
|
||||
[ [ drop ] ]
|
||||
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
|
||||
if-zero ;
|
||||
|
||||
: (neach) ( ...seq quot n -- len quot' )
|
||||
dup dup dup
|
||||
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
|
||||
|
||||
: neach ( ...seq quot n -- )
|
||||
(neach) each-integer ; inline
|
||||
|
||||
: nmap-as ( ...seq quot exemplar n -- result )
|
||||
'[ _ (neach) ] dip map-integers ; inline
|
||||
|
||||
: nmap ( ...seq quot n -- result )
|
||||
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
|
||||
|
||||
MACRO: nnew-sequence ( n -- )
|
||||
[ [ drop ] ]
|
||||
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
|
||||
|
||||
: nnew-like ( len ...exemplar quot n -- result... )
|
||||
dup dup dup dup '[
|
||||
_ nover
|
||||
[ [ _ nnew-sequence ] dip call ]
|
||||
_ ndip [ like ]
|
||||
_ apply-curry
|
||||
_ spread*
|
||||
] call ; inline
|
||||
|
||||
MACRO: (ncollect) ( n -- )
|
||||
dup dup 1 +
|
||||
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
|
||||
|
||||
: ncollect ( len quot ...into n -- )
|
||||
(ncollect) each-integer ; inline
|
||||
|
||||
: nmap-integers ( len quot ...exemplar n -- result... )
|
||||
dup dup dup
|
||||
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
|
||||
|
||||
: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
|
||||
dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
|
||||
|
||||
: mnmap ( m*seq quot m n -- result*n )
|
||||
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: grouping tools.test kernel sequences arrays
|
||||
math ;
|
||||
math accessors ;
|
||||
IN: grouping.tests
|
||||
|
||||
[ { 1 2 3 } 0 group ] must-fail
|
||||
|
|
@ -12,6 +12,15 @@ IN: grouping.tests
|
|||
>array
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [ { } 2 <clumps> length ] unit-test
|
||||
[ 0 ] [ { 1 } 2 <clumps> length ] unit-test
|
||||
[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
|
||||
[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
|
||||
|
||||
[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
|
||||
[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
|
||||
[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
|
||||
|
||||
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
|
||||
|
||||
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ M: abstract-groups group@
|
|||
TUPLE: abstract-clumps < chunking-seq ;
|
||||
|
||||
M: abstract-clumps length
|
||||
[ seq>> length ] [ n>> ] bi - 1 + ; inline
|
||||
[ seq>> length 1 + ] [ n>> ] bi [-] ; inline
|
||||
|
||||
M: abstract-clumps set-length
|
||||
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline
|
||||
|
|
|
|||
|
|
@ -53,12 +53,12 @@ HELP: <max-heap>
|
|||
{ $description "Create a new " { $link max-heap } "." } ;
|
||||
|
||||
HELP: heap-push
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
|
||||
{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } }
|
||||
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-push*
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
|
||||
{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } }
|
||||
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
|
|
@ -68,7 +68,7 @@ HELP: heap-push-all
|
|||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-peek
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $values { "heap" "a heap" } { "value" object } { "key" object } }
|
||||
{ $description "Output the first element in the heap, leaving it in the heap." } ;
|
||||
|
||||
HELP: heap-pop*
|
||||
|
|
@ -77,7 +77,7 @@ HELP: heap-pop*
|
|||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-pop
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $values { "heap" "a heap" } { "value" object } { "key" object } }
|
||||
{ $description "Output and remove the first element in the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: help.crossref help.topics help.markup tools.test words
|
||||
definitions assocs sequences kernel namespaces parser arrays
|
||||
io.streams.string continuations debugger compiler.units eval ;
|
||||
io.streams.string continuations debugger compiler.units eval
|
||||
help.syntax ;
|
||||
IN: help.crossref.tests
|
||||
|
||||
[ ] [
|
||||
|
|
@ -54,3 +55,11 @@ IN: help.crossref.tests
|
|||
] unit-test
|
||||
|
||||
[ "xxx" ] [ "yyy" article-parent ] unit-test
|
||||
|
||||
ARTICLE: "crossref-test-1" "Crossref test 1"
|
||||
"Hello world" ;
|
||||
|
||||
ARTICLE: "crossref-test-2" "Crossref test 2"
|
||||
{ $markup-example { $subsection "crossref-test-1" } } ;
|
||||
|
||||
[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,5 +4,4 @@ IN: help.handbook.tests
|
|||
[ ] [ "article-index" print-topic ] unit-test
|
||||
[ ] [ "primitive-index" print-topic ] unit-test
|
||||
[ ] [ "error-index" print-topic ] unit-test
|
||||
[ ] [ "type-index" print-topic ] unit-test
|
||||
[ ] [ "class-index" print-topic ] unit-test
|
||||
|
|
|
|||
|
|
@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index"
|
|||
ARTICLE: "error-index" "Error index"
|
||||
{ $index [ all-errors ] } ;
|
||||
|
||||
ARTICLE: "type-index" "Type index"
|
||||
{ $index [ builtins get sift ] } ;
|
||||
|
||||
ARTICLE: "class-index" "Class index"
|
||||
{ $heading "Built-in classes" }
|
||||
{ $index [ classes [ builtin-class? ] filter ] }
|
||||
|
|
@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook"
|
|||
"article-index"
|
||||
"primitive-index"
|
||||
"error-index"
|
||||
"type-index"
|
||||
"class-index"
|
||||
}
|
||||
{ $heading "Explore the code base" }
|
||||
|
|
|
|||
|
|
@ -33,14 +33,13 @@ SYMBOL: vocab-articles
|
|||
|
||||
: extract-values ( element -- seq )
|
||||
\ $values swap elements dup empty? [
|
||||
first rest [ first ] map prune natural-sort
|
||||
first rest [ first ] map prune
|
||||
] unless ;
|
||||
|
||||
: effect-values ( word -- seq )
|
||||
stack-effect
|
||||
[ in>> ] [ out>> ] bi append
|
||||
[ dup pair? [ first ] when effect>string ] map
|
||||
prune natural-sort ;
|
||||
[ dup pair? [ first ] when effect>string ] map prune ;
|
||||
|
||||
: contains-funky-elements? ( element -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -430,8 +430,8 @@ M: simple-element elements*
|
|||
M: object elements* 2drop ;
|
||||
|
||||
M: array elements*
|
||||
[ [ elements* ] with each ] 2keep
|
||||
[ first eq? ] keep swap [ , ] [ drop ] if ;
|
||||
[ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
|
||||
[ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
|
||||
|
||||
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program"
|
|||
$nl
|
||||
"In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
|
||||
{ $code "USE: palindrome" }
|
||||
"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
|
||||
"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload, in case the refresh feature does not pick up changes from disk:"
|
||||
{ $code "\"palindrome\" reload" }
|
||||
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: help.vocabs tools.test help.markup help vocabs ;
|
||||
USING: help.vocabs tools.test help.markup help vocabs io ;
|
||||
IN: help.vocabs.tests
|
||||
|
||||
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
|
||||
[ ] [ "classes" vocab print-topic ] unit-test
|
||||
[ ] [ nl ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@ images.loader images.normalization io io.binary
|
|||
io.encodings.binary io.encodings.string io.files
|
||||
io.streams.limited kernel locals macros math math.bitwise
|
||||
math.functions namespaces sequences specialized-arrays
|
||||
specialized-arrays.instances.uint
|
||||
specialized-arrays.instances.ushort strings summary ;
|
||||
strings summary ;
|
||||
SPECIALIZED-ARRAYS: uint ushort ;
|
||||
IN: images.bitmap
|
||||
|
||||
SINGLETON: bmp-image
|
||||
|
|
|
|||
|
|
@ -3,13 +3,14 @@
|
|||
USING: kernel arrays namespaces math accessors alien locals
|
||||
destructors system threads io.backend.unix.multiplexers
|
||||
io.backend.unix.multiplexers.kqueue core-foundation
|
||||
core-foundation.run-loop ;
|
||||
core-foundation.run-loop core-foundation.file-descriptors ;
|
||||
FROM: alien.c-types => void void* ;
|
||||
IN: io.backend.unix.multiplexers.run-loop
|
||||
|
||||
TUPLE: run-loop-mx kqueue-mx ;
|
||||
|
||||
: file-descriptor-callback ( -- callback )
|
||||
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
|
||||
void { CFFileDescriptorRef CFOptionFlags void* }
|
||||
"cdecl" [
|
||||
3drop
|
||||
0 mx get kqueue-mx>> wait-for-events
|
||||
|
|
|
|||
|
|
@ -68,8 +68,7 @@ ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
|
|||
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
|
||||
{ $subsections <mapped-array> }
|
||||
"Additionally, files may be opened with two combinators which take a c-type as input:"
|
||||
{ $subsections with-mapped-array }
|
||||
{ $subsections with-mapped-array-reader }
|
||||
{ $subsections with-mapped-array with-mapped-array-reader }
|
||||
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
|
||||
$nl
|
||||
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
|
||||
|
|
@ -101,10 +100,10 @@ ARTICLE: "io.mmap" "Memory-mapped files"
|
|||
{ $subsections <mapped-file> }
|
||||
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
|
||||
"Utility combinators which wrap the above:"
|
||||
{ $subsections with-mapped-file }
|
||||
{ $subsections with-mapped-file-reader }
|
||||
{ $subsections with-mapped-array }
|
||||
{ $subsections with-mapped-array-reader }
|
||||
{ $subsections with-mapped-file
|
||||
with-mapped-file-reader
|
||||
with-mapped-array
|
||||
with-mapped-array-reader }
|
||||
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
|
||||
{ $subsections
|
||||
"io.mmap.arrays"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
USING: alien.c-types alien.data compiler.tree.debugger
|
||||
continuations io.directories io.encodings.ascii io.files
|
||||
io.files.temp io.mmap kernel math sequences sequences.private
|
||||
specialized-arrays specialized-arrays.instances.uint tools.test ;
|
||||
specialized-arrays tools.test ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
|
|
|
|||
|
|
@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
|
|||
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
|
||||
] with-destructors ;
|
||||
|
||||
SYMBOL: bind-local-address
|
||||
|
||||
GENERIC: establish-connection ( client-out remote -- )
|
||||
|
||||
GENERIC: ((client)) ( remote -- handle )
|
||||
|
|
@ -321,6 +323,18 @@ M: invalid-inet-server summary
|
|||
M: inet (server)
|
||||
invalid-inet-server ;
|
||||
|
||||
ERROR: invalid-local-address addrspec ;
|
||||
|
||||
M: invalid-local-address summary
|
||||
drop "Cannot use with-local-address with <inet>; use <inet4> or <inet6> instead" ;
|
||||
|
||||
: with-local-address ( addr quot -- )
|
||||
[
|
||||
[ ] [ inet4? ] [ inet6? ] tri or
|
||||
[ bind-local-address ]
|
||||
[ invalid-local-address ] if
|
||||
] dip with-variable ; inline
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.sockets.unix" require ] }
|
||||
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] }
|
||||
|
|
|
|||
|
|
@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- )
|
|||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
: ?bind-client ( socket -- )
|
||||
bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
|
||||
|
||||
M: object ((client)) ( addrspec -- fd )
|
||||
protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
|
||||
protocol-family SOCK_STREAM socket-fd
|
||||
[ init-client-socket ] [ ?bind-client ] [ ] tri ;
|
||||
|
||||
! Server sockets - TCP and Unix domain
|
||||
: init-server-socket ( fd -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,9 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors io.sockets io.sockets.private
|
||||
io.backend.windows io.backend windows.winsock system destructors
|
||||
alien.c-types classes.struct combinators ;
|
||||
FROM: namespaces => get ;
|
||||
IN: io.sockets.windows
|
||||
|
||||
M: windows addrinfo-error ( n -- )
|
||||
|
|
@ -55,7 +58,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr )
|
|||
|
||||
M: object ((client)) ( addrspec -- handle )
|
||||
[ SOCK_STREAM open-socket ] keep
|
||||
[ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;
|
||||
[
|
||||
bind-local-address get
|
||||
[ nip make-sockaddr/size ]
|
||||
[ unspecific-sockaddr/size ] if* bind-socket
|
||||
] [ drop ] 2bi ;
|
||||
|
||||
: server-socket ( addrspec type -- fd )
|
||||
[ open-socket ] [ drop ] 2bi
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ HELP: uncons
|
|||
{ $description "Put the head and tail of the list on the stack." } ;
|
||||
|
||||
HELP: unswons
|
||||
{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
|
||||
{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
|
||||
{ $description "Put the head and tail of the list on the stack." } ;
|
||||
|
||||
{ leach foldl lmap>array } related-words
|
||||
|
|
|
|||
|
|
@ -47,19 +47,19 @@ HELP: log-message
|
|||
{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
|
||||
|
||||
HELP: add-logging
|
||||
{ $values { "level" "a log level" } { "word" word } }
|
||||
{ $values { "word" word } { "level" "a log level" } }
|
||||
{ $description "Causes the word to log a message every time it is called." } ;
|
||||
|
||||
HELP: add-input-logging
|
||||
{ $values { "level" "a log level" } { "word" word } }
|
||||
{ $values { "word" word } { "level" "a log level" } }
|
||||
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
|
||||
|
||||
HELP: add-output-logging
|
||||
{ $values { "level" "a log level" } { "word" word } }
|
||||
{ $values { "word" word } { "level" "a log level" } }
|
||||
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
|
||||
|
||||
HELP: add-error-logging
|
||||
{ $values { "level" "a log level" } { "word" word } }
|
||||
{ $values { "word" word } { "level" "a log level" } }
|
||||
{ $description "Causes the word to log its input values and any errors it throws."
|
||||
$nl
|
||||
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
|
||||
|
|
|
|||
|
|
@ -239,7 +239,7 @@ HELP: cis
|
|||
{ cis exp } related-words
|
||||
|
||||
HELP: polar>
|
||||
{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } }
|
||||
{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } }
|
||||
{ $description "Converts an absolute value and argument (polar form) to a complex number." } ;
|
||||
|
||||
HELP: [-1,1]?
|
||||
|
|
|
|||
|
|
@ -110,19 +110,9 @@ IN: math.matrices
|
|||
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
|
||||
: mnorm ( m -- n ) dup mmax abs m/n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: x ( seq -- elt ) first ; inline
|
||||
: y ( seq -- elt ) second ; inline
|
||||
: z ( seq -- elt ) third ; inline
|
||||
|
||||
: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
|
||||
: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
|
||||
: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
|
||||
: cross ( vec1 vec2 -- vec3 )
|
||||
[ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
|
||||
[ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline
|
||||
|
||||
: proj ( v u -- w )
|
||||
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ HELP: random-prime
|
|||
|
||||
HELP: unique-primes
|
||||
{ $values
|
||||
{ "numbits" integer } { "n" integer }
|
||||
{ "n" integer }
|
||||
{ "numbits" integer }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
|
||||
|
|
|
|||
|
|
@ -280,6 +280,7 @@ simd new
|
|||
} >>special-wrappers
|
||||
{
|
||||
{ { +vector+ +vector+ -> +vector+ } A-vv->v-op }
|
||||
{ { +vector+ +any-vector+ -> +vector+ } A-vv->v-op }
|
||||
{ { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
|
||||
{ { +vector+ +literal+ -> +vector+ } A-vn->v-op }
|
||||
{ { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
|
||||
|
|
|
|||
|
|
@ -163,8 +163,8 @@ M: vector-rep supported-simd-op?
|
|||
{ \ (simd-v*) [ %mul-vector-reps ] }
|
||||
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] }
|
||||
{ \ (simd-v/) [ %div-vector-reps ] }
|
||||
{ \ (simd-vmin) [ %min-vector-reps ] }
|
||||
{ \ (simd-vmax) [ %max-vector-reps ] }
|
||||
{ \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] }
|
||||
{ \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] }
|
||||
{ \ (simd-v.) [ %dot-vector-reps ] }
|
||||
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
|
||||
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
|
||||
|
|
@ -193,12 +193,12 @@ M: vector-rep supported-simd-op?
|
|||
{ \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] }
|
||||
{ \ (simd-(vunpack-head)) [ (%unpack-reps) ] }
|
||||
{ \ (simd-(vunpack-tail)) [ (%unpack-reps) ] }
|
||||
{ \ (simd-v<=) [ cc<= %compare-vector-reps ] }
|
||||
{ \ (simd-v<) [ cc< %compare-vector-reps ] }
|
||||
{ \ (simd-v=) [ cc= %compare-vector-reps ] }
|
||||
{ \ (simd-v>) [ cc> %compare-vector-reps ] }
|
||||
{ \ (simd-v>=) [ cc>= %compare-vector-reps ] }
|
||||
{ \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
|
||||
{ \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] }
|
||||
{ \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] }
|
||||
{ \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] }
|
||||
{ \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] }
|
||||
{ \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] }
|
||||
{ \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] }
|
||||
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
|
||||
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
|
||||
{ \ (simd-vany?) [ %test-vector-reps ] }
|
||||
|
|
|
|||
|
|
@ -2,17 +2,25 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel make sequences effects sets kernel.private
|
||||
accessors combinators math math.intervals math.vectors
|
||||
math.vectors.conversion.backend
|
||||
namespaces assocs fry splitting classes.algebra generalizations
|
||||
locals compiler.tree.propagation.info ;
|
||||
math.vectors.conversion.backend namespaces assocs fry splitting
|
||||
classes.algebra generalizations locals
|
||||
compiler.tree.propagation.info ;
|
||||
IN: math.vectors.specialization
|
||||
|
||||
SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
|
||||
SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
|
||||
|
||||
: parent-vector-class ( type -- type' )
|
||||
{
|
||||
{ [ dup simd-128 class<= ] [ drop simd-128 ] }
|
||||
{ [ dup simd-256 class<= ] [ drop simd-256 ] }
|
||||
[ "Not a vector class" throw ]
|
||||
} cond ;
|
||||
|
||||
: signature-for-schema ( array-type elt-type schema -- signature )
|
||||
[
|
||||
{
|
||||
{ +vector+ [ drop ] }
|
||||
{ +any-vector+ [ drop parent-vector-class ] }
|
||||
{ +scalar+ [ nip ] }
|
||||
{ +boolean+ [ 2drop boolean ] }
|
||||
{ +nonnegative+ [ nip ] }
|
||||
|
|
@ -32,6 +40,7 @@ SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
|
|||
[
|
||||
{
|
||||
{ +vector+ [ drop <class-info> ] }
|
||||
{ +any-vector+ [ drop parent-vector-class <class-info> ] }
|
||||
{ +scalar+ [ nip <class-info> ] }
|
||||
{ +boolean+ [ 2drop boolean <class-info> ] }
|
||||
{
|
||||
|
|
@ -101,7 +110,7 @@ H{
|
|||
{ hlshift { +vector+ +literal+ -> +vector+ } }
|
||||
{ hrshift { +vector+ +literal+ -> +vector+ } }
|
||||
{ vshuffle-elements { +vector+ +literal+ -> +vector+ } }
|
||||
{ vshuffle-bytes { +vector+ +vector+ -> +vector+ } }
|
||||
{ vshuffle-bytes { +vector+ +any-vector+ -> +vector+ } }
|
||||
{ vbroadcast { +vector+ +literal+ -> +vector+ } }
|
||||
{ (vmerge-head) { +vector+ +vector+ -> +vector+ } }
|
||||
{ (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
|
||||
|
|
|
|||
|
|
@ -101,6 +101,7 @@ $nl
|
|||
vxor
|
||||
vnot
|
||||
v?
|
||||
vif
|
||||
}
|
||||
"Entire vector tests:"
|
||||
{ $subsections
|
||||
|
|
@ -534,10 +535,19 @@ HELP: vnot
|
|||
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
|
||||
|
||||
HELP: v?
|
||||
{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
|
||||
{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "result" "a sequence of numbers" } }
|
||||
{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." }
|
||||
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
|
||||
|
||||
HELP: vif
|
||||
{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } }
|
||||
{ $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." }
|
||||
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types."
|
||||
$nl
|
||||
"For most conditional SIMD code, unless a case is exceptionally expensive to compute, it is usually most efficient to just compute all cases and blend them with " { $link v? } " instead of using " { $snippet "vif" } "." } ;
|
||||
|
||||
{ v? vif } related-words
|
||||
|
||||
HELP: vany?
|
||||
{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if any element of " { $snippet "v" } " is true." }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays alien.c-types assocs kernel sequences math math.functions
|
||||
hints math.order math.libm fry combinators byte-arrays accessors
|
||||
locals ;
|
||||
hints math.order math.libm math.floats.private fry combinators
|
||||
byte-arrays accessors locals ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: math.vectors
|
||||
|
||||
|
|
@ -29,8 +29,16 @@ M: object element-type drop f ; inline
|
|||
: [v-] ( u v -- w ) [ [-] ] 2map ;
|
||||
: v* ( u v -- w ) [ * ] 2map ;
|
||||
: v/ ( u v -- w ) [ / ] 2map ;
|
||||
: vmax ( u v -- w ) [ max ] 2map ;
|
||||
: vmin ( u v -- w ) [ min ] 2map ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: if-both-floats ( x y p q -- )
|
||||
[ 2dup [ float? ] both? ] 2dip if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
|
||||
: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
|
||||
|
||||
: v+- ( u v -- w )
|
||||
[ t ] 2dip
|
||||
|
|
@ -88,11 +96,12 @@ PRIVATE>
|
|||
:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
|
||||
|
||||
: vshuffle-elements ( u perm -- v )
|
||||
over length 0 pad-tail
|
||||
swap [ '[ _ nth ] ] keep map-as ;
|
||||
|
||||
: vshuffle-bytes ( u perm -- v )
|
||||
underlying>> [
|
||||
swap [ '[ _ nth ] ] keep map-as
|
||||
swap [ '[ 15 bitand _ nth ] ] keep map-as
|
||||
] curry change-underlying ;
|
||||
|
||||
GENERIC: vshuffle ( u perm -- v )
|
||||
|
|
@ -134,9 +143,16 @@ M: simd-128 vshuffle ( u perm -- v )
|
|||
: vunordered? ( u v -- w ) [ unordered? ] 2map ;
|
||||
: v= ( u v -- w ) [ = ] 2map ;
|
||||
|
||||
: v? ( mask true false -- w )
|
||||
: v? ( mask true false -- result )
|
||||
[ vand ] [ vandn ] bi-curry* bi vor ; inline
|
||||
|
||||
:: vif ( mask true-quot false-quot -- result )
|
||||
{
|
||||
{ [ mask vall? ] [ true-quot call ] }
|
||||
{ [ mask vnone? ] [ false-quot call ] }
|
||||
[ mask true-quot call false-quot call v? ]
|
||||
} cond ; inline
|
||||
|
||||
: vfloor ( u -- v ) [ floor ] map ;
|
||||
: vceiling ( u -- v ) [ ceiling ] map ;
|
||||
: vtruncate ( u -- v ) [ truncate ] map ;
|
||||
|
|
@ -163,24 +179,24 @@ PRIVATE>
|
|||
|
||||
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
|
||||
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
|
||||
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
|
||||
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; inline
|
||||
|
||||
: bilerp ( aa ba ab bb {t,u} -- a_tu )
|
||||
[ first lerp ] [ second lerp ] bi-curry
|
||||
[ 2bi@ ] [ call ] bi* ;
|
||||
[ 2bi@ ] [ call ] bi* ; inline
|
||||
|
||||
: vlerp ( a b t -- a_t )
|
||||
[ lerp ] 3map ;
|
||||
[ over v- ] dip v* v+ ; inline
|
||||
|
||||
: vnlerp ( a b t -- a_t )
|
||||
[ lerp ] curry 2map ;
|
||||
[ over v- ] dip v*n v+ ; inline
|
||||
|
||||
: vbilerp ( aa ba ab bb {t,u} -- a_tu )
|
||||
[ first vnlerp ] [ second vnlerp ] bi-curry
|
||||
[ 2bi@ ] [ call ] bi* ;
|
||||
[ 2bi@ ] [ call ] bi* ; inline
|
||||
|
||||
: v~ ( a b epsilon -- ? )
|
||||
[ ~ ] curry 2all? ;
|
||||
[ ~ ] curry 2all? ; inline
|
||||
|
||||
HINTS: vneg { array } ;
|
||||
HINTS: norm-sq { array } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: assocs hashtables kernel sequences generic words
|
||||
arrays classes slots slots.private classes.tuple
|
||||
classes.tuple.private math vectors math.vectors quotations
|
||||
accessors combinators byte-arrays specialized-arrays ;
|
||||
accessors combinators byte-arrays vocabs vocabs.loader ;
|
||||
IN: mirrors
|
||||
|
||||
TUPLE: mirror { object read-only } ;
|
||||
|
|
@ -53,12 +53,13 @@ INSTANCE: array enumerated-sequence
|
|||
INSTANCE: vector enumerated-sequence
|
||||
INSTANCE: callable enumerated-sequence
|
||||
INSTANCE: byte-array enumerated-sequence
|
||||
INSTANCE: specialized-array enumerated-sequence
|
||||
INSTANCE: simd-128 enumerated-sequence
|
||||
INSTANCE: simd-256 enumerated-sequence
|
||||
|
||||
GENERIC: make-mirror ( obj -- assoc )
|
||||
M: hashtable make-mirror ;
|
||||
M: integer make-mirror drop f ;
|
||||
M: enumerated-sequence make-mirror <enum> ;
|
||||
M: object make-mirror <mirror> ;
|
||||
|
||||
"specialized-arrays" vocab [
|
||||
"specialized-arrays.mirrors" require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1,474 @@
|
|||
! Copyright (C) 2009 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup peg peg.search ;
|
||||
IN: peg.ebnf
|
||||
|
||||
HELP: <EBNF
|
||||
{ $syntax "<EBNF ...ebnf... EBNF>" }
|
||||
{ $values { "...ebnf..." "EBNF DSL text" } }
|
||||
{ $description
|
||||
"Creates a " { $vocab-link "peg" }
|
||||
" object that parses a string using the syntax "
|
||||
"defined with the EBNF DSL. The peg object can be run using the " { $link parse }
|
||||
" word and can be used with the " { $link search } " and " { $link replace } " words."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel prettyprint peg.ebnf peg.search ;"
|
||||
"\"abcdab\" <EBNF rule=\"a\" \"b\" => [[ drop \"foo\" ]] EBNF> replace ."
|
||||
"\"foocdfoo\""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: [EBNF
|
||||
{ $syntax "[EBNF ...ebnf... EBNF]" }
|
||||
{ $values { "...ebnf..." "EBNF DSL text" } }
|
||||
{ $description
|
||||
"Creates and calls a quotation that parses a string using the syntax "
|
||||
"defined with the EBNF DSL. The quotation has stack effect "
|
||||
{ $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
|
||||
"and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
|
||||
"quotation throws an exception."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"ab\" [EBNF rule=\"a\" \"b\" EBNF] ."
|
||||
"V{ \"a\" \"b\" }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: EBNF:
|
||||
{ $syntax "EBNF: word ...ebnf... ;EBNF" }
|
||||
{ $values { "word" "a word" } { "...ebnf..." "EBNF DSL text" } }
|
||||
{ $description
|
||||
"Defines a word that when called will parse a string using the syntax "
|
||||
"defined with the EBNF DSL. The word has stack effect "
|
||||
{ $snippet "( string -- ast )" } " where 'string' is the text to be parsed "
|
||||
"and 'ast' is the resulting abstract syntax tree. If the parsing fails the "
|
||||
"word throws an exception."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"IN: scratchpad"
|
||||
"EBNF: foo rule=\"a\" \"b\" ;EBNF"
|
||||
"\"ab\" foo ."
|
||||
"V{ \"a\" \"b\" }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "peg.ebnf.strings" "Strings"
|
||||
"A string in a rule will match that sequence of characters from the input string. "
|
||||
"The AST result from the match is the string itself."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"helloworld\" [EBNF rule=\"hello\" \"world\" EBNF] ."
|
||||
"V{ \"hello\" \"world\" }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "peg.ebnf.any" "Any"
|
||||
"A full stop character (.) will match any single token in the input string. "
|
||||
"The AST resulting from this is the token itself."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"abc\" [EBNF rule=\"a\" . \"c\" EBNF] ."
|
||||
"V{ \"a\" 98 \"c\" }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "peg.ebnf.sequence" "Sequence"
|
||||
"Any white space separated rule element is considered a sequence. Each rule "
|
||||
"in the sequence is matched from the input stream, consuming the input as it "
|
||||
"goes. The AST result is a vector containing the results of each rule element in "
|
||||
"the sequence."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"abbba\" [EBNF rule=\"a\" (\"b\")* \"a\" EBNF] ."
|
||||
"V{ \"a\" V{ \"b\" \"b\" \"b\" } \"a\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.choice" "Choice"
|
||||
"Any rule element separated by a pipe character (|) is considered a choice. Choices "
|
||||
"are matched against the input stream in order. If a match succeeds then the remaining "
|
||||
"choices are discarded and the result of the match is the AST result of the choice."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"a\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
|
||||
"\"a\""
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"b\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
|
||||
"\"b\""
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"d\" [EBNF rule=\"a\" | \"b\" | \"c\" EBNF] ."
|
||||
"Peg parsing error at character position 0.\nExpected token 'c' or token 'b' or token 'a'"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.option" "Option"
|
||||
"Any rule element followed by a question mark (?) is considered optional. The "
|
||||
"rule is tested against the input. If it succeeds the result is stored in the AST. "
|
||||
"If it fails then the parse still suceeds and false (f) is stored in the AST."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"abc\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
|
||||
"V{ \"a\" \"b\" \"c\" }"
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"ac\" [EBNF rule=\"a\" \"b\"? \"c\" EBNF] ."
|
||||
"V{ \"a\" f \"c\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.character-class" "Character Class"
|
||||
"Character class matching can be done using a range of characters defined in "
|
||||
"square brackets. Multiple ranges can be included in a single character class "
|
||||
"definition. The syntax for the range is a start character, followed by a minus "
|
||||
"(-) followed by an end character. For example " { $snippet "[a-zA-Z]" } ". "
|
||||
"The AST resulting from the match is an integer of the character code for the "
|
||||
"character that matched."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"123\" [EBNF rule=[0-9]+ EBNF] ."
|
||||
"V{ 49 50 51 }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.one-or-more" "One or more"
|
||||
"Any rule element followed by a plus (+) matches one or more instances of the rule "
|
||||
"from the input string. The AST result is the vector of the AST results from "
|
||||
"the matched rule."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"aab\" [EBNF rule=\"a\"+ \"b\" EBNF] ."
|
||||
"V{ V{ \"a\" \"a\" } \"b\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.zero-or-more" "Zero or more"
|
||||
"Any rule element followed by an asterisk (*) matches zero or more instances of the rule "
|
||||
"from the input string. The AST result is the vector of the AST results from "
|
||||
"the matched rule. This will be empty if there are no matches."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"aab\" [EBNF rule=\"a\"* \"b\" EBNF] ."
|
||||
"V{ V{ \"a\" \"a\" } \"b\" }"
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"b\" [EBNF rule=\"a\"* \"b\" EBNF] ."
|
||||
"V{ V{ } \"b\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.and" "And"
|
||||
"Any rule element prefixed by an ampersand (&) performs the Parsing Expression "
|
||||
"Grammar 'And Predicate' match. It attempts to match the rule against the input "
|
||||
"string. It will cause the parse to succeed or fail depending on if the rule "
|
||||
"succeeds or fails. It will not consume anything from the input string however and "
|
||||
"does not leave any result in the AST. This can be used for lookahead and "
|
||||
"disambiguation in choices."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"ab\" [EBNF rule=&(\"a\") \"a\" \"b\" EBNF] ."
|
||||
"V{ \"a\" \"b\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.not" "Not"
|
||||
"Any rule element prefixed by an exclamation mark (!) performs the Parsing Expression "
|
||||
"Grammar 'Not Predicate' match. It attempts to match the rule against the input "
|
||||
"string. It will cause the parse to succeed if the rule match fails, and to fail "
|
||||
"if the rule match succeeds. It will not consume anything from the input string "
|
||||
"however and does not leave any result in the AST. This can be used for lookahead and "
|
||||
"disambiguation in choices."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"\"<abcd>\" [EBNF rule=\"<\" (!(\">\") .)* \">\" EBNF] ."
|
||||
"V{ \"<\" V{ 97 98 99 100 } \">\" }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.action" "Action"
|
||||
"An action is a quotation that is run after a rule matches. The quotation "
|
||||
"consumes the AST of the rule match and leaves a new AST as the result. "
|
||||
"The stack effect of the action can be " { $snippet "( ast -- ast )" } " or "
|
||||
{ $snippet "( -- ast )" } ". "
|
||||
"If it is the latter then the original AST is implcitly dropped and will be "
|
||||
"replaced by the AST left on the stack. This is mostly useful if variables are "
|
||||
"used in the rule since they can be referenced like locals in the action quotation. "
|
||||
"The action is defined by having a ' => ' at the end of a rule and "
|
||||
"using '[[' and ']]' to open and close the quotation. "
|
||||
"If an action leaves the object 'ignore' on the stack then the result of that "
|
||||
"action will not be put in the AST of the result."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf strings ;"
|
||||
"\"<abcd>\" [EBNF rule=\"<\" ((!(\">\") .)* => [[ >string ]]) \">\" EBNF] ."
|
||||
"V{ \"<\" \"abcd\" \">\" }"
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf math.parser ;"
|
||||
"\"123\" [EBNF rule=[0-9]+ => [[ string>number ]] EBNF] ."
|
||||
"123"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.semantic-action" "Semantic Action"
|
||||
"Semantic actions allow providing a quotation that gets run on the AST of a "
|
||||
"matched rule that returns success or failure. The result of the parse is decided by "
|
||||
"the result of the semantic action. The stack effect for the quotation is "
|
||||
{ $snippet ( ast -- ? ) } ". "
|
||||
"A semantic action follows the rule it applies to and is delimeted by '?[' and ']?'."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf math math.parser ;"
|
||||
"\"1\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
|
||||
"49"
|
||||
}
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf math math.parser ;"
|
||||
"\"2\" [EBNF rule=[0-9] ?[ digit> odd? ]? EBNF] ."
|
||||
"Sequence index out of bounds\nindex 0\nseq V{ }"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.variable" "Variable"
|
||||
"Variables names can be suffixed to a rule element using the colon character (:) "
|
||||
"followed by the variable name. These can then be used in rule actions to refer to "
|
||||
"the AST result of the rule element with that variable name."
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg.ebnf math.parser ;"
|
||||
"\"1+2\" [EBNF rule=[0-9]:a \"+\" [0-9]:b => [[ a digit> b digit> + ]] EBNF] ."
|
||||
"3"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.foreign-rules" "Foreign Rules"
|
||||
"Rules can call outto other peg.ebnf defined parsers. The result of "
|
||||
"the foreign call then becomes the AST of the successful parse. Foreign rules "
|
||||
"are invoked using '<foreign word-name>' or '<foreign word-name rule>'. The "
|
||||
"latter allows calling a specific rule in a previously designed peg.ebnf parser. "
|
||||
"If the 'word-name' is not the name of a peg.ebnf defined parser then it must be "
|
||||
"a word with stack effect " { $snippet "( -- parser )" } ". It must return a "
|
||||
{ $vocab-link "peg" } " defined parser and it will be called to perform the parse "
|
||||
"for that rule."
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: prettyprint peg.ebnf ;"
|
||||
"EBNF: parse-string"
|
||||
"StringBody = (!('\"') .)*"
|
||||
"String= '\"' StringBody:b '\"' => [[ b >string ]]"
|
||||
";EBNF"
|
||||
"EBNF: parse-two-strings"
|
||||
"TwoStrings = <foreign parse-string String> <foreign parse-string String>"
|
||||
";EBNF"
|
||||
"EBNF: parse-two-strings"
|
||||
"TwoString = <foreign parse-string> <foreign parse-string>"
|
||||
";EBNF"
|
||||
}
|
||||
{ $code
|
||||
": a-token ( -- parser ) \"a\" token ;"
|
||||
"EBNF: parse-abc"
|
||||
"abc = <foreign a-token> 'b' 'c'"
|
||||
";EBNF"
|
||||
}
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf.tokenizers" "Tokenizers"
|
||||
"It is possible to override the tokenizer in an EBNF defined parser. "
|
||||
"Usually the input sequence to be parsed is an array of characters or a string. "
|
||||
"Terminals in a rule match successive characters in the array or string. "
|
||||
{ $examples
|
||||
{ $code
|
||||
"EBNF: foo"
|
||||
"rule = \"++\" \"--\""
|
||||
";EBNF"
|
||||
}
|
||||
}
|
||||
"This parser when run with the string \"++--\" or the array "
|
||||
"{ CHAR: + CHAR: + CHAR: - CHAR: - } will succeed with an AST of { \"++\" \"--\" }. "
|
||||
"If you want to add whitespace handling to the grammar you need to put it "
|
||||
"between the terminals: "
|
||||
{ $examples
|
||||
{ $code
|
||||
"EBNF: foo"
|
||||
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
|
||||
"spaces = space* => [[ drop ignore ]]"
|
||||
"rule = spaces \"++\" spaces \"--\" spaces"
|
||||
";EBNF"
|
||||
}
|
||||
}
|
||||
"In a large grammar this gets tedious and makes the grammar hard to read. "
|
||||
"Instead you can write a rule to split the input sequence into tokens, and "
|
||||
"have the grammar operate on these tokens. This is how the previous example "
|
||||
"might look: "
|
||||
{ $examples
|
||||
{ $code
|
||||
"EBNF: foo"
|
||||
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
|
||||
"spaces = space* => [[ drop ignore ]]"
|
||||
"tokenizer = spaces ( \"++\" | \"--\" )"
|
||||
"rule = \"++\" \"--\""
|
||||
";EBNF"
|
||||
}
|
||||
}
|
||||
"'tokenizer' is the name of a built in rule. Once defined it is called to "
|
||||
"retrieve the next complete token from the input sequence. So the first part "
|
||||
"of 'rule' is to try and match \"++\". It calls the tokenizer to get the next "
|
||||
"complete token. This ignores spaces until it finds a \"++\" or \"--\". "
|
||||
"It is as if the input sequence for the parser was actually { \"++\" \"--\" } "
|
||||
"instead of the string \"++--\". With the new tokenizer \"....\" sequences "
|
||||
"in the grammar are matched for equality against the token, rather than a "
|
||||
"string comparison against successive items in the sequence. This can be used "
|
||||
"to match an AST from a tokenizer. "
|
||||
$nl
|
||||
"In this example I split the tokenizer into a separate parser and use "
|
||||
"'foreign' to call it from the main one. This allows testing of the "
|
||||
"tokenizer separately: "
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint peg peg.ebnf kernel math.parser strings"
|
||||
"accessors math arrays ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"TUPLE: ast-number value ;"
|
||||
"TUPLE: ast-string value ;"
|
||||
""
|
||||
"EBNF: foo-tokenizer"
|
||||
"space = (\" \" | \"\\r\" | \"\\t\" | \"\\n\")"
|
||||
"spaces = space* => [[ drop ignore ]]"
|
||||
""
|
||||
"number = [0-9]+ => [[ >string string>number ast-number boa ]]"
|
||||
"operator = (\"+\" | \"-\")"
|
||||
""
|
||||
"token = spaces ( number | operator )"
|
||||
"tokens = token*"
|
||||
";EBNF"
|
||||
""
|
||||
"EBNF: foo"
|
||||
"tokenizer = <foreign foo-tokenizer token>"
|
||||
""
|
||||
"number = . ?[ ast-number? ]? => [[ value>> ]]"
|
||||
"string = . ?[ ast-string? ]? => [[ value>> ]]"
|
||||
""
|
||||
"rule = string:a number:b \"+\" number:c => [[ a b c + 2array ]]"
|
||||
";EBNF"
|
||||
""
|
||||
"\"123 456 +\" foo-tokenizer ."
|
||||
"V{\n T{ ast-number { value 123 } }\n T{ ast-number { value 456 } }\n \"+\"\n}"
|
||||
}
|
||||
}
|
||||
"The '.' EBNF production means match a single object in the source sequence. "
|
||||
"Usually this is a character. With the replacement tokenizer it is either a "
|
||||
"number object, a string object or a string containing the operator. "
|
||||
"Using a tokenizer in language grammars makes it easier to deal with whitespace. "
|
||||
"Defining tokenizers in this way has the advantage of the tokenizer and parser "
|
||||
"working in one pass. There is no tokenization occurring over the whole string "
|
||||
"followed by the parse of that result. It tokenizes as it needs to. You can even "
|
||||
"switch tokenizers multiple times during a grammar. Rules use the tokenizer that "
|
||||
"was defined lexically before the rule. This is usefull in the JavaScript grammar: "
|
||||
{ $examples
|
||||
{ $code
|
||||
"EBNF: javascript"
|
||||
"tokenizer = default"
|
||||
"nl = \"\\r\" \"\\n\" | \"\\n\""
|
||||
"tokenizer = <foreign tokenize-javascript Tok>"
|
||||
"..."
|
||||
"End = !(.)"
|
||||
"Name = . ?[ ast-name? ]? => [[ value>> ]] "
|
||||
"Number = . ?[ ast-number? ]? => [[ value>> ]]"
|
||||
"String = . ?[ ast-string? ]? => [[ value>> ]]"
|
||||
"RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]"
|
||||
"SpacesNoNl = (!(nl) Space)* => [[ ignore ]]"
|
||||
"Sc = SpacesNoNl (nl | &(\"}\") | End)| \";\""
|
||||
}
|
||||
}
|
||||
"Here the rule 'nl' is defined using the default tokenizer of sequential "
|
||||
"characters ('default' has the special meaning of the built in tokenizer). "
|
||||
"This is followed by using the JavaScript tokenizer for the remaining rules. "
|
||||
"This tokenizer strips out whitespace and newlines. Some rules in the grammar "
|
||||
"require checking for a newline. In particular the automatic semicolon insertion "
|
||||
"rule (managed by the 'Sc' rule here). If there is a newline, the semicolon can "
|
||||
"be optional in places. "
|
||||
{ $examples
|
||||
{ $code
|
||||
"\"do\" Stmt:s \"while\" \"(\" Expr:c \")\" Sc => [[ s c ast-do-while boa ]]"
|
||||
}
|
||||
}
|
||||
"Even though the JavaScript tokenizer has removed the newlines, the 'nl' rule can "
|
||||
"be used to detect them since it is using the default tokenizer. This allows "
|
||||
"grammars to mix and match the tokenizer as required to make them more readable."
|
||||
;
|
||||
|
||||
ARTICLE: "peg.ebnf" "EBNF"
|
||||
"The " { $vocab-link "peg.ebnf" } " vocabulary provides a DSL that allows writing PEG parsers that look like "
|
||||
"EBNF syntax. It provides three parsing words described below. These words all "
|
||||
"accept the same EBNF syntax. The difference is in how they are used. "
|
||||
{ $subsection POSTPONE: <EBNF }
|
||||
{ $subsection POSTPONE: [EBNF }
|
||||
{ $subsection POSTPONE: EBNF: }
|
||||
"The EBNF syntax is composed of a series of rules of the form: "
|
||||
{ $code
|
||||
"rule1 = ..."
|
||||
"rule2 = ..."
|
||||
}
|
||||
"The last defined rule is the main rule for the EBNF. It is the first one run "
|
||||
"and it is expected that the remaining rules are used by that rule. Rules may be "
|
||||
"left recursive. "
|
||||
"Each rule can contain the following: "
|
||||
{ $subsection "peg.ebnf.strings" }
|
||||
{ $subsection "peg.ebnf.any" }
|
||||
{ $subsection "peg.ebnf.sequence" }
|
||||
{ $subsection "peg.ebnf.choice" }
|
||||
{ $subsection "peg.ebnf.option" }
|
||||
{ $subsection "peg.ebnf.one-or-more" }
|
||||
{ $subsection "peg.ebnf.zero-or-more" }
|
||||
{ $subsection "peg.ebnf.and" }
|
||||
{ $subsection "peg.ebnf.not" }
|
||||
{ $subsection "peg.ebnf.character-class" }
|
||||
{ $subsection "peg.ebnf.foreign-rules" }
|
||||
{ $subsection "peg.ebnf.action" }
|
||||
{ $subsection "peg.ebnf.semantic-action" }
|
||||
{ $subsection "peg.ebnf.variable" }
|
||||
"Grammars defined in EBNF need to handle each character, or sequence of "
|
||||
"characters in the input. This can be tedious for dealing with whitespace in "
|
||||
"grammars that have 'tokens' separated by whitespace. You can define your "
|
||||
"own tokenizer that for an EBNF grammar, and write the grammar in terms of "
|
||||
"those tokens, allowing you to ignore the whitespace issue. The tokenizer "
|
||||
"can be changed at various parts in the grammar as needed. The JavaScript grammar "
|
||||
"does this to define the optional semicolon rule for example."
|
||||
{ $subsection "peg.ebnf.tokenizers" }
|
||||
;
|
||||
|
||||
ABOUT: "peg.ebnf"
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test peg peg.ebnf words math math.parser
|
||||
sequences accessors peg.parsers parser namespaces arrays
|
||||
strings eval unicode.data multiline ;
|
||||
USING: kernel tools.test peg peg.ebnf peg.ebnf.private words
|
||||
math math.parser sequences accessors peg.parsers parser
|
||||
namespaces arrays strings eval unicode.data multiline ;
|
||||
IN: peg.ebnf.tests
|
||||
|
||||
{ T{ ebnf-non-terminal f "abc" } } [
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@ IN: peg.ebnf
|
|||
|
||||
ERROR: no-rule rule parser ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: lookup-rule ( rule parser -- rule' )
|
||||
2dup rule [ 2nip ] [ no-rule ] if* ;
|
||||
|
||||
|
|
@ -540,6 +542,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
|
|||
parse-ebnf dup dup parser [ main swap at compile ] with-variable
|
||||
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: <EBNF
|
||||
"EBNF>"
|
||||
reset-tokenizer parse-multiline-string parse-ebnf main swap at
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ HELP: pheap-peek
|
|||
{ $description "Gets the object in the heap with minumum priority." } ;
|
||||
|
||||
HELP: pheap-push
|
||||
{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
|
||||
{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
|
||||
{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
|
||||
|
||||
HELP: pheap-pop*
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors alien.c-types kernel locals math math.ranges
|
|||
math.bitwise math.vectors math.vectors.simd random
|
||||
sequences specialized-arrays sequences.private classes.struct
|
||||
combinators.short-circuit fry ;
|
||||
SIMD: uint
|
||||
SIMDS: uchar uint ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
SPECIALIZED-ARRAY: uint-4
|
||||
IN: random.sfmt
|
||||
|
|
@ -28,14 +28,25 @@ TUPLE: sfmt
|
|||
{ uint-array uint-array }
|
||||
{ uint-4-array uint-4-array } ;
|
||||
|
||||
: endian-shuffle ( v -- w )
|
||||
little-endian? [
|
||||
uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } vshuffle
|
||||
] unless ; inline
|
||||
|
||||
: hlshift* ( v n -- w )
|
||||
[ endian-shuffle ] dip hlshift endian-shuffle ; inline
|
||||
|
||||
: hrshift* ( v n -- w )
|
||||
[ endian-shuffle ] dip hrshift endian-shuffle ; inline
|
||||
|
||||
: wA ( w -- wA )
|
||||
dup 1 hlshift vbitxor ; inline
|
||||
dup 1 hlshift* vbitxor ; inline
|
||||
|
||||
: wB ( w mask -- wB )
|
||||
[ 11 vrshift ] dip vbitand ; inline
|
||||
|
||||
: wC ( w -- wC )
|
||||
1 hrshift ; inline
|
||||
1 hrshift* ; inline
|
||||
|
||||
: wD ( w -- wD )
|
||||
18 vlshift ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,46 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: help.syntax help.markup kernel sequences quotations
|
||||
math arrays combinators ;
|
||||
IN: sequences.generalizations
|
||||
|
||||
HELP: neach
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
|
||||
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: nmap
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
|
||||
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: nmap-as
|
||||
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
|
||||
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
|
||||
|
||||
HELP: mnmap
|
||||
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
|
||||
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
|
||||
|
||||
HELP: mnmap-as
|
||||
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
|
||||
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
|
||||
|
||||
HELP: nproduce
|
||||
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
|
||||
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
|
||||
|
||||
HELP: nproduce-as
|
||||
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
|
||||
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
|
||||
|
||||
ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
|
||||
"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
|
||||
{ $subsections
|
||||
neach
|
||||
nmap
|
||||
nmap-as
|
||||
mnmap
|
||||
mnmap-as
|
||||
nproduce
|
||||
nproduce-as
|
||||
} ;
|
||||
|
||||
ABOUT: "sequences.generalizations"
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: tools.test generalizations kernel math arrays sequences
|
||||
sequences.generalizations ascii fry math.parser io io.streams.string ;
|
||||
IN: sequences.generalizations.tests
|
||||
|
||||
: neach-test ( a b c d -- )
|
||||
[ 4 nappend print ] 4 neach ;
|
||||
: nmap-test ( a b c d -- e )
|
||||
[ 4 nappend ] 4 nmap ;
|
||||
: nmap-as-test ( a b c d -- e )
|
||||
[ 4 nappend ] [ ] 4 nmap-as ;
|
||||
: mnmap-3-test ( a b c d -- e f g )
|
||||
[ append ] 4 3 mnmap ;
|
||||
: mnmap-2-test ( a b c d -- e f )
|
||||
[ [ append ] 2bi@ ] 4 2 mnmap ;
|
||||
: mnmap-as-test ( a b c d -- e f )
|
||||
[ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
|
||||
: mnmap-1-test ( a b c d -- e )
|
||||
[ 4 nappend ] 4 1 mnmap ;
|
||||
: mnmap-0-test ( a b c d -- )
|
||||
[ 4 nappend print ] 4 0 mnmap ;
|
||||
: nproduce-as-test ( n -- a b )
|
||||
[ dup zero? not ]
|
||||
[ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as
|
||||
[ drop ] 2dip ;
|
||||
: nproduce-test ( n -- a b )
|
||||
[ dup zero? not ]
|
||||
[ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce
|
||||
[ drop ] 2dip ;
|
||||
|
||||
[ """A1a!
|
||||
B2b@
|
||||
C3c#
|
||||
D4d$
|
||||
""" ] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
[ neach-test ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
nmap-test
|
||||
] unit-test
|
||||
|
||||
[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
nmap-as-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a!" "b@" "c#" "d$" }
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-3-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A1" "B2" "C3" "D4" }
|
||||
{ "a!" "b@" "c#" "d$" }
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-2-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "A1" "B2" "C3" "D4" }
|
||||
[ "a!" "b@" "c#" "d$" ]
|
||||
] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-as-test
|
||||
] unit-test
|
||||
|
||||
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
|
||||
[
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
mnmap-1-test
|
||||
] unit-test
|
||||
|
||||
[ """A1a!
|
||||
B2b@
|
||||
C3c#
|
||||
D4d$
|
||||
""" ] [
|
||||
{ "A" "B" "C" "D" }
|
||||
{ "1" "2" "3" "4" }
|
||||
{ "a" "b" "c" "d" }
|
||||
{ "!" "@" "#" "$" }
|
||||
[ mnmap-0-test ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ]
|
||||
[ 10 nproduce-as-test ] unit-test
|
||||
|
||||
[ { 10 8 6 4 2 } { 9 7 5 3 1 } ]
|
||||
[ 10 nproduce-test ] unit-test
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: kernel sequences sequences.private math
|
||||
combinators macros math.order math.ranges quotations fry effects
|
||||
memoize.private generalizations ;
|
||||
IN: sequences.generalizations
|
||||
|
||||
MACRO: nmin-length ( n -- )
|
||||
dup 1 - [ min ] n*quot
|
||||
'[ [ length ] _ napply @ ] ;
|
||||
|
||||
: nnth-unsafe ( n ...seq n -- )
|
||||
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
|
||||
MACRO: nset-nth-unsafe ( n -- )
|
||||
[ [ drop ] ]
|
||||
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
|
||||
if-zero ;
|
||||
|
||||
: (neach) ( ...seq quot n -- len quot' )
|
||||
dup dup dup
|
||||
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
|
||||
|
||||
: neach ( ...seq quot n -- )
|
||||
(neach) each-integer ; inline
|
||||
|
||||
: nmap-as ( ...seq quot exemplar n -- result )
|
||||
'[ _ (neach) ] dip map-integers ; inline
|
||||
|
||||
: nmap ( ...seq quot n -- result )
|
||||
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
|
||||
|
||||
MACRO: nnew-sequence ( n -- )
|
||||
[ [ drop ] ]
|
||||
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
|
||||
|
||||
: nnew-like ( len ...exemplar quot n -- result... )
|
||||
5 dupn '[
|
||||
_ nover
|
||||
[ [ _ nnew-sequence ] dip call ]
|
||||
_ ndip [ like ]
|
||||
_ apply-curry
|
||||
_ spread*
|
||||
] call ; inline
|
||||
|
||||
MACRO: (ncollect) ( n -- )
|
||||
3 dupn 1 +
|
||||
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
|
||||
|
||||
: ncollect ( len quot ...into n -- )
|
||||
(ncollect) each-integer ; inline
|
||||
|
||||
: nmap-integers ( len quot ...exemplar n -- result... )
|
||||
4 dupn
|
||||
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
|
||||
|
||||
: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
|
||||
dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
|
||||
|
||||
: mnmap ( m*seq quot m n -- result*n )
|
||||
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
|
||||
|
||||
: naccumulator-for ( quot ...exemplar n -- quot' vec... )
|
||||
5 dupn '[
|
||||
[ [ length ] keep new-resizable ] _ napply
|
||||
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
|
||||
] call ; inline
|
||||
|
||||
: naccumulator ( quot n -- quot' vec... )
|
||||
[ V{ } swap dupn ] keep naccumulator-for ; inline
|
||||
|
||||
: nproduce-as ( pred quot ...exemplar n -- seq... )
|
||||
7 dupn '[
|
||||
_ ndup
|
||||
[ _ naccumulator-for [ while ] _ ndip ]
|
||||
_ ncurry _ ndip
|
||||
[ like ] _ apply-curry _ spread*
|
||||
] call ; inline
|
||||
|
||||
: nproduce ( pred quot n -- seq... )
|
||||
[ { } swap dupn ] keep nproduce-as ; inline
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! Copyright (C) 2009 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: mirrors specialized-arrays math.vectors ;
|
||||
IN: specialized-arrays.mirrors
|
||||
|
||||
INSTANCE: specialized-array enumerated-sequence
|
||||
INSTANCE: simd-128 enumerated-sequence
|
||||
INSTANCE: simd-256 enumerated-sequence
|
||||
|
|
@ -86,7 +86,7 @@ ARTICLE: "specialized-array-examples" "Specialized array examples"
|
|||
ARTICLE: "specialized-arrays" "Specialized arrays"
|
||||
"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
|
||||
$nl
|
||||
"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
|
||||
"A specialized array type needs to be generated for each element type. This is done with parsing words:"
|
||||
{ $subsections
|
||||
POSTPONE: SPECIALIZED-ARRAY:
|
||||
POSTPONE: SPECIALIZED-ARRAYS:
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ specialized-arrays.private sequences alien.c-types accessors
|
|||
kernel arrays combinators compiler compiler.units classes.struct
|
||||
combinators.smart compiler.tree.debugger math libc destructors
|
||||
sequences.private multiline eval words vocabs namespaces
|
||||
assocs prettyprint alien.data math.vectors ;
|
||||
assocs prettyprint alien.data math.vectors definitions ;
|
||||
FROM: alien.c-types => float ;
|
||||
|
||||
SPECIALIZED-ARRAY: int
|
||||
|
|
@ -120,10 +120,7 @@ SPECIALIZED-ARRAY: fixed-string
|
|||
[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
|
||||
|
||||
! If the C type doesn't exist, don't generate a vocab
|
||||
[ ] [
|
||||
[ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
|
||||
"__does_not_exist__" c-types get delete-at
|
||||
] unit-test
|
||||
SYMBOL: __does_not_exist__
|
||||
|
||||
[
|
||||
"""
|
||||
|
|
@ -146,6 +143,13 @@ SPECIALIZED-ARRAY: __does_not_exist__
|
|||
|
||||
[ f ] [
|
||||
"__does_not_exist__-array{"
|
||||
"__does_not_exist__" specialized-array-vocab lookup
|
||||
__does_not_exist__ specialized-array-vocab lookup
|
||||
deferred?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ __does_not_exist__ forget
|
||||
__does_not_exist__ specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ libc math math.vectors math.vectors.private
|
|||
math.vectors.specialization namespaces
|
||||
parser prettyprint.custom sequences sequences.private strings
|
||||
summary vocabs vocabs.loader vocabs.parser vocabs.generated
|
||||
words fry combinators present ;
|
||||
words fry combinators make ;
|
||||
IN: specialized-arrays
|
||||
|
||||
MIXIN: specialized-array
|
||||
|
|
@ -125,11 +125,13 @@ M: word (underlying-type) "c-type" word-prop ;
|
|||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: underlying-type-name ( c-type -- name )
|
||||
underlying-type present ;
|
||||
|
||||
: specialized-array-vocab ( c-type -- vocab )
|
||||
present "specialized-arrays.instances." prepend ;
|
||||
[
|
||||
"specialized-arrays.instances." %
|
||||
[ vocabulary>> % "." % ]
|
||||
[ name>> % ]
|
||||
bi
|
||||
] "" make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -143,18 +145,18 @@ M: c-type-name require-c-array define-array-vocab drop ;
|
|||
ERROR: specialized-array-vocab-not-loaded c-type ;
|
||||
|
||||
M: c-type-name c-array-constructor
|
||||
underlying-type-name
|
||||
dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
underlying-type
|
||||
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
|
||||
M: c-type-name c-(array)-constructor
|
||||
underlying-type-name
|
||||
dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
|
||||
underlying-type
|
||||
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
|
||||
M: c-type-name c-direct-array-constructor
|
||||
underlying-type-name
|
||||
dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
underlying-type
|
||||
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
|
||||
[ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
|
||||
|
||||
SYNTAX: SPECIALIZED-ARRAYS:
|
||||
|
|
@ -166,3 +168,7 @@ SYNTAX: SPECIALIZED-ARRAY:
|
|||
"prettyprint" vocab [
|
||||
"specialized-arrays.prettyprint" require
|
||||
] when
|
||||
|
||||
"mirrors" vocab [
|
||||
"specialized-arrays.mirrors" require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -6,6 +6,13 @@ HELP: SPECIALIZED-VECTOR:
|
|||
{ $values { "type" "a C type" } }
|
||||
{ $description "Brings a specialized vector for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
|
||||
|
||||
HELP: SPECIALIZED-VECTORS:
|
||||
{ $syntax "SPECIALIZED-VECTORS: type type type ... ;" }
|
||||
{ $values { "type" "a C type" } }
|
||||
{ $description "Brings a set of specialized vectors for holding values of each " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
|
||||
|
||||
{ POSTPONE: SPECIALIZED-VECTOR: POSTPONE: SPECIALIZED-VECTORS: } related-words
|
||||
|
||||
ARTICLE: "specialized-vector-words" "Specialized vector words"
|
||||
"The " { $link POSTPONE: SPECIALIZED-VECTOR: } " parsing word generates the specialized vector type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
|
||||
{ $table
|
||||
|
|
@ -21,6 +28,12 @@ ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
|
|||
|
||||
ARTICLE: "specialized-vectors" "Specialized vectors"
|
||||
"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
|
||||
$nl
|
||||
"A specialized vector type needs to be generated for each element type. This is done with parsing words:"
|
||||
{ $subsections
|
||||
POSTPONE: SPECIALIZED-VECTOR:
|
||||
POSTPONE: SPECIALIZED-VECTORS:
|
||||
}
|
||||
{ $subsections
|
||||
"specialized-vector-words"
|
||||
"specialized-vector-c"
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@ IN: specialized-vectors.tests
|
|||
USING: specialized-arrays specialized-vectors
|
||||
tools.test kernel sequences alien.c-types ;
|
||||
SPECIALIZED-ARRAY: float
|
||||
SPECIALIZED-VECTOR: float
|
||||
SPECIALIZED-VECTOR: double
|
||||
SPECIALIZED-VECTORS: float double ;
|
||||
|
||||
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types assocs compiler.units functors
|
||||
growable kernel lexer namespaces parser prettyprint.custom
|
||||
sequences specialized-arrays specialized-arrays.private strings
|
||||
vocabs vocabs.parser vocabs.generated fry ;
|
||||
USING: accessors alien.c-types alien.parser assocs
|
||||
compiler.units functors growable kernel lexer namespaces parser
|
||||
prettyprint.custom sequences specialized-arrays
|
||||
specialized-arrays.private strings vocabs vocabs.parser
|
||||
vocabs.generated fry make ;
|
||||
QUALIFIED: vectors.functor
|
||||
IN: specialized-vectors
|
||||
|
||||
|
|
@ -41,8 +42,13 @@ INSTANCE: V S
|
|||
|
||||
;FUNCTOR
|
||||
|
||||
: specialized-vector-vocab ( type -- vocab )
|
||||
"specialized-vectors.instances." prepend ;
|
||||
: specialized-vector-vocab ( c-type -- vocab )
|
||||
[
|
||||
"specialized-vectors.instances." %
|
||||
[ vocabulary>> % "." % ]
|
||||
[ name>> % ]
|
||||
bi
|
||||
] "" make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -51,7 +57,14 @@ PRIVATE>
|
|||
[ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
|
||||
generate-vocab ;
|
||||
|
||||
SYNTAX: SPECIALIZED-VECTORS:
|
||||
";" parse-tokens [
|
||||
parse-c-type
|
||||
[ define-array-vocab use-vocab ]
|
||||
[ define-vector-vocab use-vocab ] bi
|
||||
] each ;
|
||||
|
||||
SYNTAX: SPECIALIZED-VECTOR:
|
||||
scan
|
||||
scan-c-type
|
||||
[ define-array-vocab use-vocab ]
|
||||
[ define-vector-vocab use-vocab ] bi ;
|
||||
|
|
|
|||
|
|
@ -507,10 +507,10 @@ M: bad-executable summary
|
|||
|
||||
\ (save-image-and-exit) { byte-array } { } define-primitive
|
||||
|
||||
\ data-room { } { integer integer array } define-primitive
|
||||
\ data-room { } { array } define-primitive
|
||||
\ data-room make-flushable
|
||||
|
||||
\ code-room { } { integer integer integer integer } define-primitive
|
||||
\ code-room { } { array } define-primitive
|
||||
\ code-room make-flushable
|
||||
|
||||
\ micros { } { integer } define-primitive
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ $nl
|
|||
{ $heading "Limitations" }
|
||||
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
|
||||
{ $example
|
||||
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
|
||||
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected"
|
||||
}
|
||||
"To make this work, pass the quotation on the retain stack instead:"
|
||||
{ $example
|
||||
|
|
@ -74,7 +74,7 @@ $nl
|
|||
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
|
||||
{ $heading "Input quotation declaration" }
|
||||
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
|
||||
{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
|
||||
{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected" }
|
||||
"The following is correct:"
|
||||
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
|
||||
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
|
||||
|
|
@ -82,7 +82,7 @@ $nl
|
|||
"The stack checker does not trace data flow in two instances."
|
||||
$nl
|
||||
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
|
||||
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
|
||||
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected" }
|
||||
"However a small change can be made:"
|
||||
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
|
||||
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ SPECIALIZED-ARRAY: char
|
|||
IN: system-info.linux
|
||||
|
||||
: (uname) ( buf -- int )
|
||||
"int" f "uname" { "char*" } alien-invoke ;
|
||||
int f "uname" { char* } alien-invoke ;
|
||||
|
||||
: uname ( -- seq )
|
||||
65536 <char-array> [ (uname) io-error ] keep
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ IN: tools.deploy.tests
|
|||
|
||||
[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
|
||||
[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
|
||||
|
||||
|
|
@ -114,4 +114,4 @@ os macosx? [
|
|||
rest
|
||||
] unit-test
|
||||
|
||||
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
|
||||
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue