-IN: alarms.tests\r
USING: alarms alarms.private kernel calendar sequences\r
tools.test threads concurrency.count-downs ;\r
+IN: alarms.tests\r
\r
[ ] [\r
1 <count-down>\r
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
-kernel math namespaces sequences heaps boxes threads
-quotations assocs math.order ;
+USING: accessors assocs boxes calendar
+combinators.short-circuit fry heaps init kernel math.order
+namespaces quotations threads ;
IN: alarms
TUPLE: alarm
ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f )
- dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+ dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
- dup dup time>> alarms get-global heap-push*
- swap entry>> >box
+ [ dup time>> alarms get-global heap-push* ]
+ [ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
- dup [ swap interval>> time+ now max ] change-time register-alarm ;
+ dup '[ _ interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
-IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
CONSTANT: xyz 123
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
- >>
+>>
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests
: (shuffle-map) ( return parameters -- ret par )
[
- fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+ fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
- [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+ [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
-IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
-[ "fdasfsf" dll-valid? drop ] must-fail
\ No newline at end of file
+[ "fdasfsf" dll-valid? drop ] must-fail
-IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
C-STRUCT: bar
{ "int" "x" }
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
+ERROR: no-such-symbol name library ;
+
: address-of ( name library -- value )
- load-library dlsym [ "No such symbol" throw ] unless* ;
+ 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;
[ 4 ] [
0 "There are Four Upper Case characters"
- [ LETTER? [ 1+ ] when ] each
+ [ LETTER? [ 1 + ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
: write1-lines ( ch -- )
write1
column get [
- 1+ [ 76 = [ crlf ] when ]
+ 1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
- [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
+ [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+USING: biassocs assocs namespaces tools.test hashtables kernel ;
IN: biassocs.tests
-USING: biassocs assocs namespaces tools.test ;
<bihash> "h" set
[ "A" ] [ "a" "b" get at ] unit-test
-[ "a" ] [ "A" "b" get value-at ] unit-test
\ No newline at end of file
+[ "a" ] [ "A" "b" get value-at ] unit-test
+
+[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
+
+[ ] [ "h" get clone "g" set ] unit-test
+
+[ ] [ 3 4 "g" get set-at ] unit-test
+
+[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
+
+[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test
INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc )
- T{ biassoc } assoc-clone-like ;
\ No newline at end of file
+ T{ biassoc } assoc-clone-like ;
+
+M: biassoc clone
+ [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;
-IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
: <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
M: bit-array nth-unsafe
- [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+ [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep
- swap n>byte set-alien-unsigned-1 ;
+ swap n>byte set-alien-unsigned-1 ; inline
GENERIC: clear-bits ( bit-array -- )
-M: bit-array clear-bits 0 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- )
-M: bit-array set-bits -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ; inline
M: bit-array clone
- [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+ [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
resize-byte-array
] 2bi
bit-array boa
- dup clean-up ;
+ dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ;
dup 0 = [
<bit-array>
] [
- [ log2 1+ <bit-array> 0 ] keep
+ [ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
- [ 1+ ] [ -8 shift ] bi*
+ [ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;
-IN: bit-sets.tests
USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
-IN: bit-vectors.tests\r
USING: tools.test bit-vectors vectors sequences kernel math ;\r
+IN: bit-vectors.tests\r
\r
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
io.streams.byte-array ;
IN: bitstreams.tests
-
[ BIN: 1111111111 ]
[
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
- [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+ [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: compile-unoptimized ( words -- )
[ optimized? not ] filter compile ;
-nl
-"Compiling..." write flush
+"debug-compiler" get [
+
+ nl
+ "Compiling..." write flush
-! Compile a set of words ahead of the full compile.
-! This set of words was determined semi-empirically
-! using the profiler. It improves bootstrap time
-! significantly, because frequenly called words
-! which are also quick to compile are replaced by
-! compiled definitions as soon as possible.
-{
- not ?
+ ! Compile a set of words ahead of the full compile.
+ ! This set of words was determined semi-empirically
+ ! using the profiler. It improves bootstrap time
+ ! significantly, because frequenly called words
+ ! which are also quick to compile are replaced by
+ ! compiled definitions as soon as possible.
+ {
+ not ?
- 2over roll -roll
+ 2over roll -roll
- array? hashtable? vector?
- tuple? sbuf? tombstone?
- curry? compose? callable?
- quotation?
+ array? hashtable? vector?
+ tuple? sbuf? tombstone?
+ curry? compose? callable?
+ quotation?
- curry compose uncurry
+ curry compose uncurry
- array-nth set-array-nth length>>
+ array-nth set-array-nth length>>
- wrap probe
+ wrap probe
- namestack*
+ namestack*
- layout-of
-} compile-unoptimized
+ layout-of
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- bitand bitor bitxor bitnot
-} compile-unoptimized
+ {
+ bitand bitor bitxor bitnot
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- + 1+ 1- 2/ < <= > >= shift
-} compile-unoptimized
+ {
+ + 2/ < <= > >= shift
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- new-sequence nth push pop last flip
-} compile-unoptimized
+ {
+ new-sequence nth push pop last flip
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- hashcode* = equal? assoc-stack (assoc-stack) get set
-} compile-unoptimized
+ {
+ hashcode* = equal? assoc-stack (assoc-stack) get set
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- memq? split harvest sift cut cut-slice start index clone
- set-at reverse push-all class number>string string>number
- like clone-like
-} compile-unoptimized
+ {
+ memq? split harvest sift cut cut-slice start index clone
+ set-at reverse push-all class number>string string>number
+ like clone-like
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- lines prefix suffix unclip new-assoc update
- word-prop set-word-prop 1array 2array 3array ?nth
-} compile-unoptimized
+ {
+ lines prefix suffix unclip new-assoc update
+ word-prop set-word-prop 1array 2array 3array ?nth
+ } compile-unoptimized
-"." write flush
+ "." write flush
-{
- malloc calloc free memcpy
-} compile-unoptimized
+ {
+ malloc calloc free memcpy
+ } compile-unoptimized
-"." write flush
+ "." write flush
-vocabs [ words compile-unoptimized "." write flush ] each
+ vocabs [ words compile-unoptimized "." write flush ] each
-" done" print flush
+ " done" print flush
+
+] unless
\ No newline at end of file
-IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
+IN: bootstrap.image.tests
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
-: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
- [ nip length 1+ emit-fixnum ]
+ [ nip length 1 + emit-fixnum ]
[ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
SYMBOL: upload-images-destination
: destination ( -- dest )
- upload-images-destination get
- "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
- or ;
+ upload-images-destination get
+ "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+ or ;
: checksums ( -- temp ) "checksums.txt" temp-file ;
"math.ratios" require
"math.floats" require
-"math.complex" require
\ No newline at end of file
+"math.complex" require
"tools.test"
"tools.time"
"tools.threads"
+ "tools.deprecation"
"vocabs.hierarchy"
"vocabs.refresh"
"vocabs.refresh.monitor"
-IN: boxes.tests\r
USING: boxes namespaces tools.test accessors ;\r
+IN: boxes.tests\r
\r
[ ] [ <box> "b" set ] unit-test\r
\r
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;
-
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests
: purge-cache ( cache -- )
dup max-age>> '[
- [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+ [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
[ values dispose-each ] dip
- ] change-assoc drop ;
\ No newline at end of file
+ ] change-assoc drop ;
-IN: cairo.tests
USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
[ { 10 20 } ] [
{ 10 20 } [
{ 0 1 } { 3 4 } <rect> fill-rect
] make-bitmap-image dim>>
-] unit-test
\ No newline at end of file
+] unit-test
} ;
HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
{ $description "Returns an array with the English names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
- dup zero? [ not-a-month ] when ;
+ [ not-a-month ] when-zero ;
PRIVATE>
-: month-names ( -- array )
+CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
- } ;
+ }
: month-name ( n -- string )
- check-month 1- month-names nth ;
+ check-month 1 - month-names nth ;
CONSTANT: month-abbreviations
{
}
: month-abbreviation ( n -- string )
- check-month 1- month-abbreviations nth ;
+ check-month 1 - month-abbreviations nth ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
- e 153 m * 2 + 5 /i - 1+ ;
+ e 153 m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' )
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
[ 3 >>month 1 >>day ] when ;
-: unless-zero ( n quot -- )
- [ dup zero? [ drop ] ] dip if ; inline
-
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
- 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+ 12 /rem [ 1 - 12 ] when-zero swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
[
- dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
+ dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
- [ 1+ 3 * 5 /i + ] keep 2 * +
- ] dip 1+ + 7 mod ;
+ [ 1 + 3 * 5 /i + ] keep 2 * +
+ ] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n )
year leap-year? [
year month day <date>
year 3 1 <date>
- after=? [ 1+ ] when
+ after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
over " " <repetition> concat write\r
[\r
- [ 1+ day. ] keep\r
- 1+ + 7 mod zero? [ nl ] [ bl ] if\r
+ [ 1 + day. ] keep\r
+ 1 + + 7 mod zero? [ nl ] [ bl ] if\r
] with each nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1+ 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
\r
: read-rfc3339-seconds ( s -- s' ch )\r
"+-Z" read-until [\r
- [ string>number ] [ length 10 swap ^ ] bi / +\r
+ [ string>number ] [ length 10^ ] bi / +\r
] dip ;\r
\r
: (rfc3339>timestamp) ( -- timestamp )\r
"," read-token day-abbreviations3 member? check-timestamp drop\r
read1 CHAR: \s assert=\r
read-sp checked-number >>day\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
"," read-token check-day-name\r
read1 CHAR: \s assert=\r
"-" read-token checked-number >>day\r
- "-" read-token month-abbreviations index 1+ check-timestamp >>month\r
+ "-" read-token month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
: (cookie-string>timestamp-2) ( -- timestamp )\r
timestamp new\r
read-sp check-day-name\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>day\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
IN: channels.examples
: (counter) ( channel n -- )
- [ swap to ] 2keep 1+ (counter) ;
+ [ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;
! Copyright (C) 2009 Alaric Snell-Pym
! See http://factorcode.org/license.txt for BSD license.
-
USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ;
-
IN: checksums.fnv1
SINGLETON: fnv1-32
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays checksums checksums.md5 io.encodings.binary
io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
! See http;//factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private
circular strings ;
+IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
- [ [ 1+ ] change-length set-last ] if ;
+ [ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
-IN: cocoa.callbacks
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
+IN: cocoa.callbacks
SYMBOL: callbacks
-IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ;
+IN: cocoa.tests
CLASS: {
{ +superclass+ "NSObject" }
[ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
- [ [ 1+ ] dip ] [ nth ] 2bi {
+ [ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
-IN: cocoa.plists.tests
USING: tools.test cocoa.plists colors kernel hashtables
core-foundation.utilities core-foundation destructors
assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
[
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
[ 3.5 ] [
3.5 >cf &CFRelease plist>
] unit-test
-] with-destructors
\ No newline at end of file
+] with-destructors
-IN: colors.hsv.tests
USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
: hsv>rgb ( h s v -- r g b )
[ 360 * ] 2dip
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
-[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
\ No newline at end of file
+[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
-IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
-
USING: kernel math tools.test combinators.short-circuit.smart ;
-
IN: combinators.short-circuit.smart.tests
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
-[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
-
-[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
-[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
+[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
+[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
+[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test
-USING: kernel sequences math stack-checker effects accessors macros
-fry combinators.short-circuit ;
+USING: kernel sequences math stack-checker effects accessors
+macros fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
+ERROR: cannot-determine-arity ;
+
: arity ( quots -- n )
first infer
- dup terminated?>> [ "Cannot determine arity" throw ] when
- effect-height neg 1+ ;
+ dup terminated?>> [ cannot-determine-arity ] when
+ effect-height neg 1 + ;
PRIVATE>
{ $example
<" USING: combinators combinators.smart math prettyprint ;
9 [
- { [ 1- ] [ 1+ ] [ sq ] } cleave
+ { [ 1 - ] [ 1 + ] [ sq ] } cleave
] output>array .">
"{ 8 10 81 }"
}
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
- "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+ "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
"20"
}
} ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
- 10 [ 1- ] [ 1+ ] bi ;
+ 10 [ 1 - ] [ 1 + ] bi ;
[ [ test-bi ] output>array ] must-infer
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
-[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
\ No newline at end of file
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+++ /dev/null
-IN: compiler.cfg.alias-analysis.tests
SYMBOL: ac-counter
: next-ac ( -- n )
- ac-counter [ dup 1+ ] change ;
+ ac-counter [ dup 1 + ] change ;
! Alias class for objects which are loaded from the data stack
! or other object slots. We pessimistically assume that they
eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
- [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
+ [ alias-analysis-step ] local-optimization ;
-IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
-strings.private ;
+strings.private accessors compiler.cfg.instructions ;
+IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
] each
+
+: contains-insn? ( quot insn-check -- ? )
+ [ test-mr [ instructions>> ] map ] dip
+ '[ _ any? ] any? ; inline
+
+[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ t ] [
+ [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
+ [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ t ] [
+ [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
+ [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+ [ { byte-array fixnum } declare set-alien-unsigned-1 ]
+ [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
\ No newline at end of file
compiler.cfg.predecessors compiler.cfg ;
IN: compiler.cfg.dataflow-analysis
-GENERIC: join-sets ( sets dfa -- set )
+GENERIC: join-sets ( sets bb dfa -- set )
GENERIC: transfer-set ( in-set bb dfa -- out-set )
GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
- bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+ ! Only consider initialized sets.
+ bb dfa predecessors
+ [ out-sets key? ] filter
+ [ out-sets at ] map
+ bb dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
in-sets
out-sets ; inline
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
FUNCTOR: define-analysis ( name -- )
compiler.cfg.debugger
compiler.cfg.instructions
compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
V{
T{ ##peek f 0 D 0 }
-IN: compiler.cfg.dominance.tests
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
compiler.cfg.predecessors ;
+IN: compiler.cfg.dominance.tests
: test-dominance ( -- )
cfg new 0 get >>entry
-IN: compiler.cfg.gc-checks.tests
USING: compiler.cfg.gc-checks compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
+IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
\ No newline at end of file
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
- '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+ '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
- [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+ [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
-IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
accessors
compiler.cfg
compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.resolve.tests
[
{
T{ _reload { dst 0 } { rep int-rep } { n 8 } }
}
} member?
-] unit-test
\ No newline at end of file
+] unit-test
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions <simple-block> insert-basic-block
+ mapping-instructions insert-simple-basic-block
cfg get cfg-changed drop
] if ;
+++ /dev/null
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-
drop instructions>> transfer-liveness ;
M: live-analysis join-sets
- drop assoc-combine ;
\ No newline at end of file
+ 2drop assoc-combine ;
-IN: compiler.cfg.loop-detection.tests
USING: compiler.cfg compiler.cfg.loop-detection
compiler.cfg.predecessors
compiler.cfg.debugger
tools.test kernel namespaces accessors ;
+IN: compiler.cfg.loop-detection.tests
V{ } 0 test-bb
V{ } 1 test-bb
TUPLE: natural-loop header index ends blocks ;
-<PRIVATE
-
SYMBOL: loops
+<PRIVATE
+
: <natural-loop> ( header index -- loop )
H{ } clone H{ } clone natural-loop boa ;
: needs-loops ( cfg -- cfg' )
needs-predecessors
- dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
\ No newline at end of file
+ dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
- [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+ [ 2drop ] [ insert-simple-basic-block ] if-empty
] if ;
: visit-block ( bb -- )
dup [ visit-block ] each-basic-block
- cfg-changed ;
\ No newline at end of file
+ cfg-changed ;
M: live-analysis transfer-set drop transfer-peeked-locs ;
-M: live-analysis join-sets drop assoc-combine ;
+M: live-analysis join-sets 2drop assoc-combine ;
! A stack location is available at a location if all paths from
! the entry block to the location load the location into a
[ compute-dead-sets ]
[ compute-avail-sets ]
[ ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
: peek-loc ( loc -- vreg )
translate-local-loc
- dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
- dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+ dup replace-mapping get at
+ [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- )
- translate-local-loc
- 2dup loc>vreg =
- [ nip replace-mapping get delete-at ]
- [
- [ local-replace-set get conjoin ]
- [ replace-mapping get set-at ]
- bi
- ] if ;
+ translate-local-loc replace-mapping get set-at ;
: compute-local-kill-set ( -- assoc )
basic-block get current-height get
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
- H{ } clone local-replace-set set
H{ } clone replace-mapping set
current-height get
[ 0 >>emit-d 0 >>emit-r drop ]
[ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
+: remove-redundant-replaces ( -- )
+ replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
+ [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
+
: end-local-analysis ( -- )
+ remove-redundant-replaces
emit-changes
basic-block get {
[ [ local-peek-set get ] dip peek-sets get set-at ]
-IN: compiler.cfg.stacks.uninitialized.tests
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
+IN: compiler.cfg.stacks.uninitialized.tests
: test-uninitialized ( -- )
cfg new 0 get >>entry
drop [ prepare ] dip visit-block finish ;
M: uninitialized-analysis join-sets ( sets analysis -- pair )
- drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+ 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
: uninitialized-locs ( bb -- locs )
uninitialized-in dup [
[ [ <ds-loc> ] (uninitialized-locs) ]
[ [ <rs-loc> ] (uninitialized-locs) ]
bi* append
- ] when ;
\ No newline at end of file
+ ] when ;
-IN: compiler.cfg.two-operand.tests
USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
compiler.cfg.registers cpu.architecture namespaces tools.test ;
+IN: compiler.cfg.two-operand.tests
3 vreg-counter set-global
USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo ;
+compiler.cfg.rpo arrays ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( from to bb -- )
- bb from 1vector >>predecessors drop
+:: insert-basic-block ( froms to bb -- )
+ bb froms V{ } like >>predecessors drop
bb to 1vector >>successors drop
- to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
- from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+ to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
+ froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
- @
+ [ @ ] dip
,
] with-variable ; inline
\ ##branch new-insn over push
>>instructions ;
+: insert-simple-basic-block ( from to insns -- )
+ [ 1vector ] 2dip <simple-block> insert-basic-block ;
+
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
-USING: compiler.cfg.write-barrier compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors
-compiler.cfg.utilities ;
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs compiler.cfg
+compiler.cfg.alias-analysis compiler.cfg.block-joining
+compiler.cfg.branch-splitting compiler.cfg.copy-prop
+compiler.cfg.dce compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.loop-detection
+compiler.cfg.registers compiler.cfg.ssa.construction
+compiler.cfg.tco compiler.cfg.useless-conditionals
+compiler.cfg.utilities compiler.cfg.value-numbering
+compiler.cfg.write-barrier cpu.architecture kernel
+kernel.private math namespaces sequences sequences.private
+tools.test vectors ;
IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
T{ ##write-barrier f 19 30 3 }
} test-write-barrier
] unit-test
+
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+ T{ ##allot f 1 }
+} 1 test-bb
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+ T{ ##allot f 1 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+ T{ ##allot }
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+ T{ ##allot }
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+ T{ ##allot }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} 3 test-bb
+2 get 3 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
+[ V{
+ T{ ##set-slot-imm f 2 1 3 4 }
+ T{ ##write-barrier f 1 2 3 }
+} ] [ 3 get instructions>> ] unit-test
+
+: reverse-here' ( seq -- )
+ { array } declare
+ [ length 2/ iota ] [ length ] [ ] tri
+ [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
+
+: write-barrier-stats ( word -- cfg )
+ test-cfg first [
+ optimize-tail-calls
+ delete-useless-conditionals
+ split-branches
+ join-blocks
+ construct-ssa
+ alias-analysis
+ value-numbering
+ copy-propagation
+ eliminate-dead-code
+ eliminate-write-barriers
+ ] with-cfg
+ post-order>> write-barriers
+ [ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
+
+[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+fry combinators.short-circuit locals make arrays
+compiler.cfg
+compiler.cfg.dominance
+compiler.cfg.predecessors
+compiler.cfg.loop-detection
+compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.dataflow-analysis
+compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
dst>> safe get conjoin t ;
M: ##write-barrier eliminate-write-barrier
- src>> dup [ safe get key? not ] [ mutated get key? ] bi and
+ src>> dup safe get key? not
[ safe get conjoin t ] [ drop f ] if ;
-M: ##set-slot eliminate-write-barrier
+M: insn eliminate-write-barrier drop t ;
+
+! This doesn't actually benefit from being a dataflow analysis
+! might as well be dominator-based
+! Dealing with phi functions would help, though
+FORWARD-ANALYSIS: safe
+
+: has-allocation? ( bb -- ? )
+ instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
+
+M: safe-analysis transfer-set
+ drop [ H{ } assoc-clone-like safe set ] dip
+ instructions>> [
+ eliminate-write-barrier drop
+ ] each safe get ;
+
+M: safe-analysis join-sets
+ drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
+
+: write-barriers-step ( bb -- )
+ dup safe-in H{ } assoc-clone-like safe set
+ instructions>> [ eliminate-write-barrier ] filter-here ;
+
+GENERIC: remove-dead-barrier ( insn -- ? )
+
+M: ##write-barrier remove-dead-barrier
+ src>> mutated get key? ;
+
+M: ##set-slot remove-dead-barrier
obj>> mutated get conjoin t ;
-M: ##set-slot-imm eliminate-write-barrier
+M: ##set-slot-imm remove-dead-barrier
obj>> mutated get conjoin t ;
-M: insn eliminate-write-barrier drop t ;
+M: insn remove-dead-barrier drop t ;
-: write-barriers-step ( bb -- )
- H{ } clone safe set
+: remove-dead-barriers ( bb -- )
H{ } clone mutated set
- instructions>> [ eliminate-write-barrier ] filter-here ;
+ instructions>> [ remove-dead-barrier ] filter-here ;
+
+! Availability of slot
+! Anticipation of this and set-slot would help too, maybe later
+FORWARD-ANALYSIS: slot
+
+UNION: access ##read ##write ;
+
+M: slot-analysis transfer-set
+ drop [ H{ } assoc-clone-like ] dip
+ instructions>> over '[
+ dup access? [
+ obj>> _ conjoin
+ ] [ drop ] if
+ ] each ;
+
+: slot-available? ( vreg bb -- ? )
+ slot-in key? ;
+
+: make-barriers ( vregs -- bb )
+ [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
+
+: emit-barriers ( vregs loop -- )
+ swap [
+ [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
+ [ header>> ] bi
+ ] [ make-barriers ] bi*
+ insert-basic-block ;
+
+: write-barriers ( bbs -- bb=>barriers )
+ [
+ dup instructions>>
+ [ ##write-barrier? ] filter
+ [ src>> ] map
+ ] { } map>assoc
+ [ nip empty? not ] assoc-filter ;
+
+: filter-dominant ( bb=>barriers bbs -- barriers )
+ '[ drop _ [ dominates? ] with all? ] assoc-filter
+ values concat prune ;
+
+: dominant-write-barriers ( loop -- vregs )
+ [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
+
+: safe-loops ( -- loops )
+ loops get values
+ [ blocks>> keys [ has-allocation? not ] all? ] filter ;
+
+:: insert-extra-barriers ( cfg -- )
+ safe-loops [| loop |
+ cfg needs-dominance needs-predecessors drop
+ loop dominant-write-barriers
+ loop header>> '[ _ slot-available? ] filter
+ [ loop emit-barriers cfg cfg-changed drop ] unless-empty
+ ] each ;
+
+: contains-write-barrier? ( cfg -- ? )
+ post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
: eliminate-write-barriers ( cfg -- cfg' )
- dup [ write-barriers-step ] each-basic-block ;
+ dup contains-write-barrier? [
+ needs-loops
+ dup [ remove-dead-barriers ] each-basic-block
+ dup compute-slot-sets
+ dup insert-extra-barriers
+ dup compute-safe-sets
+ dup [ write-barriers-step ] each-basic-block
+ ] when ;
-IN: compiler.codegen.tests
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ;
+IN: compiler.codegen.tests
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
} cond ;
: optimize? ( word -- ? )
- { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+ single-generic? not ;
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
- + + 1+
+ + + 1 +
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
ffi_test_48
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tests.call-effect
USING: tools.test combinators generic.single sequences kernel ;
+IN: compiler.tests.call-effect
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
[ ] [ [ ] call-test ] unit-test
[ ] [ f [ drop ] curry call-test ] unit-test
[ ] [ [ ] [ ] compose call-test ] unit-test
-[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
\ No newline at end of file
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
-IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;
+IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
-IN: compiler.tests.generic
USING: tools.test math kernel compiler.units definitions ;
+IN: compiler.tests.generic
GENERIC: bad ( -- )
M: integer bad ;
[ 0 bad ] must-fail
[ "" bad ] must-fail
-[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
\ No newline at end of file
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions ;
+compiler definitions generic.single ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
+: (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
! regression
: branch-fold-regression-0 ( m -- n )
- t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
+ t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
! Type inference issue
[ 4 3 ] [
1 >bignum 2 >bignum
- [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+ [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
] unit-test
: broken-declaration ( -- ) \ + declare ;
\ bad-dispatch-position-test forget
\ bad-dispatch-position-test* forget
] with-compilation-unit
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Not sure if I want to fix this...
+! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
\ No newline at end of file
-IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
+IN: compiler.tests.peg-regression-2
GENERIC: <times> ( times -- term' )
M: string <times> ;
-IN: compiler.tests.pic-problem-1
USING: kernel sequences prettyprint memory tools.test ;
+IN: compiler.tests.pic-problem-1
TUPLE: x ;
CONSTANT: blah T{ x }
-[ T{ x } ] [ blah ] unit-test
\ No newline at end of file
+[ T{ x } ] [ blah ] unit-test
-IN: compiler.tests.redefine0
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
namespaces macros assocs ;
+IN: compiler.tests.redefine0
! Test ripple-up behavior
: test-1 ( -- a ) 3 ;
: word-3 ( a -- b ) 1 + ;
-: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
+: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ;
[ 1 1 ] [ 0 word-4 ] unit-test
-IN: compiler.tests.redefine16
USING: eval tools.test definitions words compiler.units
quotations stack-checker ;
+IN: compiler.tests.redefine16
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
-IN: compiler.tests.redefine17
USING: tools.test classes.mixin compiler.units arrays kernel.private
strings sequences vocabs definitions kernel ;
+IN: compiler.tests.redefine17
<< "compiler.tests.redefine17" words forget-all >>
-IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
+IN: compiler.tests.redefine2
DEFER: redefine2-test
-IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
+IN: compiler.tests.redefine3
GENERIC: sheeple ( obj -- x )
-M: object sheeple drop "sheeple" ;
+M: object sheeple drop "sheeple" ; inline
MIXIN: empty-mixin
-M: empty-mixin sheeple drop "wake up" ;
+M: empty-mixin sheeple drop "wake up" ; inline
: sheeple-test ( -- string ) { } sheeple ;
-IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
+IN: compiler.tests.redefine4
: declaration-test-1 ( -- a ) 3 ; flushable
-IN: compiler.tests.reload
USE: vocabs.loader
+IN: compiler.tests.reload
! "parser" reload
! "sequences" reload
-IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;
+IN: compiler.tests.stack-trace
: symbolic-stack-trace ( -- newseq )
error-continuation get call>> callstack>array
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
- [ word? ] filter
+ 2 head*
{ baz bar foo } tail?
] unit-test
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
] unit-test
-
+
[ t f ] [
[ { "hi" } bleh ] ignore-errors
\ + stack-trace-any?
-IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
+IN: compiler.tests.tuples
TUPLE: color red green blue ;
-IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
compiler.tree stack-checker stack-checker.errors ;
+IN: compiler.tree.builder.tests
: inline-recursive ( -- ) inline-recursive ; inline recursive
+++ /dev/null
-IN: compiler.tree.checker.tests
-USING: compiler.tree.checker tools.test ;
-
-
-IN: compiler.tree.cleanup.tests
USING: tools.test kernel.private kernel arrays sequences
math.private math generic words quotations alien alien.c-types
strings sbufs sequences.private slots.private combinators
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
+IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
GENERIC: mynot ( x -- y )
-M: f mynot drop t ;
+M: f mynot drop t ; inline
-M: object mynot drop f ;
+M: object mynot drop f ; inline
GENERIC: detect-f ( x -- y )
-M: f detect-f ;
+M: f detect-f ; inline
[ t ] [
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
GENERIC: xyz ( n -- n )
-M: integer xyz ;
+M: integer xyz ; inline
-M: object xyz ;
+M: object xyz ; inline
[ t ] [
[ { integer } declare xyz ] \ xyz inlined?
2over dup xyz drop >= [
3drop
] [
- [ swap [ call 1+ ] dip ] keep (i-repeat)
+ [ swap [ call 1 + ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ { fixnum } declare [ ] times ] \ >= inlined?
] unit-test
-[ t ] [
- [ { fixnum } declare [ ] times ] \ 1+ inlined?
-] unit-test
-
[ t ] [
[ { fixnum } declare [ ] times ] \ + inlined?
] unit-test
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
] unit-test
-[ t ] [
- [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 [ [ ] times ] each ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
- \ 1+ inlined?
-] unit-test
-
GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
2dup >= [
2drop
] [
- [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
+ [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
] \ + inlined?
] unit-test
-[ t ] [
- [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
-] unit-test
-
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline recursive
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
- [ 1+ ] dip buffalo-wings
+ [ 1 + ] dip buffalo-wings
] [
2drop
] if ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
- [ 1+ ] dip ribs
+ [ 1 + ] dip ribs
] [
2drop
] if ; inline recursive
[ 12 swap nth ] keep
14 ndrop
] cleaned-up-tree nodes>quot
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.combinators.tests
USING: compiler.tree.combinators tools.test kernel ;
+IN: compiler.tree.combinators.tests
{ 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 1 } [ [ ] map-nodes ] must-infer-as
USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
stack-checker.branches compiler.tree compiler.tree.combinators
-compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
-;
+compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
IN: compiler.tree.dead-code.branches
M: #if mark-live-values* look-at-inputs ;
-IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
+IN: compiler.tree.debugger.tests
[ [ <=> ] sort ] optimized.
-[ <reversed> [ print ] each ] optimizer-report.
\ No newline at end of file
+[ <reversed> [ print ] each ] optimizer-report.
compiler.tree.cleanup
compiler.tree.propagation
compiler.tree.propagation.info
+compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing
compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
H{ } clone intrinsics-called set
0 swap [
- [ 1+ ] dip
+ [ 1 + ] dip
dup #call? [
word>> {
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
normalize
propagate
cleanup
+ escape-analysis
+ unbox-tuples
apply-identities
compute-def-use
remove-dead-code
ERROR: no-def-error value ;
: def-of ( value -- definition )
- dup def-use get at* [ nip ] [ no-def-error ] if ;
+ def-use get ?at [ no-def-error ] unless ;
ERROR: multiple-defs-error ;
USING: kernel tools.test compiler.tree compiler.tree.builder
-compiler.tree.def-use compiler.tree.def-use.simplified accessors
-sequences sorting classes ;
+compiler.tree.recursive compiler.tree.def-use
+compiler.tree.def-use.simplified accessors sequences sorting classes ;
IN: compiler.tree.def-use.simplified
[ { #call #return } ] [
first out-d>> first actually-used-by
[ node>> class ] map natural-sort
] unit-test
+
+: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive
+
+[ { #introduce } ] [
+ [ word-1 ] build-tree analyze-recursive compute-def-use
+ last in-d>> first actually-defined-by
+ [ node>> class ] map natural-sort
+] unit-test
+
+[ { #if #return } ] [
+ [ word-1 ] build-tree analyze-recursive compute-def-use
+ first out-d>> first actually-used-by
+ [ node>> class ] map natural-sort
+] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel fry vectors
-compiler.tree compiler.tree.def-use ;
+USING: sequences kernel fry vectors accessors namespaces assocs sets
+stack-checker.branches compiler.tree compiler.tree.def-use ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.
! A 'real' usage is a usage of a value that is not a #renaming.
TUPLE: real-usage value node ;
+<PRIVATE
+
+SYMBOLS: visited accum ;
+
+: if-not-visited ( value quot -- )
+ over visited get key?
+ [ 2drop ] [ over visited get conjoin call ] if ; inline
+
+: with-simplified-def-use ( quot -- real-usages )
+ [
+ H{ } clone visited set
+ H{ } clone accum set
+ call
+ accum get keys
+ ] with-scope ; inline
+
+PRIVATE>
+
! Def
-GENERIC: actually-defined-by* ( value node -- real-usage )
+GENERIC: actually-defined-by* ( value node -- )
-: actually-defined-by ( value -- real-usage )
- dup defined-by actually-defined-by* ;
+: (actually-defined-by) ( value -- )
+ [ dup defined-by actually-defined-by* ] if-not-visited ;
M: #renaming actually-defined-by*
- inputs/outputs swap [ index ] dip nth actually-defined-by ;
+ inputs/outputs swap [ index ] dip nth (actually-defined-by) ;
+
+M: #call-recursive actually-defined-by*
+ [ out-d>> index ] [ label>> return>> in-d>> nth ] bi
+ (actually-defined-by) ;
-M: #return-recursive actually-defined-by* real-usage boa ;
+M: #enter-recursive actually-defined-by*
+ [ out-d>> index ] keep
+ [ in-d>> nth (actually-defined-by) ]
+ [ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ;
-M: node actually-defined-by* real-usage boa ;
+M: #phi actually-defined-by*
+ [ out-d>> index ] [ phi-in-d>> ] bi
+ [
+ nth dup +bottom+ eq?
+ [ drop ] [ (actually-defined-by) ] if
+ ] with each ;
+
+M: node actually-defined-by*
+ real-usage boa accum get conjoin ;
+
+: actually-defined-by ( value -- real-usages )
+ [ (actually-defined-by) ] with-simplified-def-use ;
! Use
-GENERIC# actually-used-by* 1 ( value node accum -- )
+GENERIC: actually-used-by* ( value node -- )
-: (actually-used-by) ( value accum -- )
- [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
+: (actually-used-by) ( value -- )
+ [ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
M: #renaming actually-used-by*
- [ inputs/outputs [ indices ] dip nths ] dip
- '[ _ (actually-used-by) ] each ;
+ inputs/outputs [ indices ] dip nths
+ [ (actually-used-by) ] each ;
+
+M: #return-recursive actually-used-by*
+ [ in-d>> index ] keep
+ [ out-d>> nth (actually-used-by) ]
+ [ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ;
+
+M: #call-recursive actually-used-by*
+ [ in-d>> index ] [ label>> enter-out>> nth ] bi
+ (actually-used-by) ;
+
+M: #enter-recursive actually-used-by*
+ [ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ;
+
+M: #phi actually-used-by*
+ [ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi
+ (actually-used-by) ;
-M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
+M: #recursive actually-used-by* 2drop ;
-M: node actually-used-by* [ real-usage boa ] dip push ;
+M: node actually-used-by*
+ real-usage boa accum get conjoin ;
: actually-used-by ( value -- real-usages )
- 10 <vector> [ (actually-used-by) ] keep ;
+ [ (actually-used-by) ] with-simplified-def-use ;
-IN: compiler.tree.escape-analysis.check.tests
USING: compiler.tree.escape-analysis.check tools.test accessors kernel
kernel.private math compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup ;
+IN: compiler.tree.escape-analysis.check.tests
: test-checker ( quot -- ? )
build-tree normalize propagate cleanup run-escape-analysis? ;
[ f ] [
[ swap 1 2 ? ]
test-checker
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.recursive compiler.tree.normalization
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private vectors ;
+IN: compiler.tree.escape-analysis.tests
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
- out-d>> first escaping-allocation? [ 1+ ] unless ;
+ out-d>> first escaping-allocation? [ 1 + ] unless ;
M: #call count-unboxed-allocations*
dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #introduce count-unboxed-allocations*
- out-d>> [ escaping-allocation? [ 1+ ] unless ] each ;
+ out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
M: node count-unboxed-allocations* drop ;
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup tuple-fib
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
tuple-fib
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: tuple-fib' ( m -- n )
- dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+ dup 1 <= [ 1 - tuple-fib' i>> ] when <ro-box> ; inline recursive
[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-1
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-1 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-2
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-2
+ 1 - dup tuple-fib-2
swap
- 1- tuple-fib-2
+ 1 - tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-3
+ 1 - dup tuple-fib-3
swap
- 1- tuple-fib-3 dup .
+ 1 - tuple-fib-3 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup bad-tuple-fib-3
+ 1 - dup bad-tuple-fib-3
swap
- 1- bad-tuple-fib-3
+ 1 - bad-tuple-fib-3
2drop f
] if ; inline recursive
[ 0 ] [
[ { vector } declare length>> ]
count-unboxed-allocations
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.escape-analysis.recursive.tests
USING: kernel tools.test namespaces sequences
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.recursive.tests
H{ } clone allocations set
<escaping-values> escaping-values set
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize combinators
-classes classes.builtin classes.tuple math.partial-dispatch
-fry assocs combinators.short-circuit
+classes classes.builtin classes.tuple classes.singleton
+math.partial-dispatch fry assocs combinators.short-circuit
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
"predicating" word-prop {
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
+ { [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
[ drop ]
} cond ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences sequences.private strings sbufs
-compiler.tree.builder
-compiler.tree.normalization
-compiler.tree.debugger
-alien.accessors layouts combinators byte-arrays ;
+prettyprint math.private accessors slots.private sequences
+sequences.private strings sbufs compiler.tree.builder
+compiler.tree.normalization compiler.tree.debugger alien.accessors
+layouts combinators byte-arrays arrays ;
+IN: compiler.tree.modular-arithmetic.tests
: test-modular-arithmetic ( quot -- quot' )
cleaned-up-tree nodes>quot ;
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
-
-
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod rem } inlined?
] unit-test
-[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >fixnum 255 >R R> fixnum-bitand ] ]
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
+[ t ] [
+ [ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
[ t ] [
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
{ >fixnum } inlined?
+] unit-test
+
+[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test
+
+[ t ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+ { >bignum } inlined?
+] unit-test
+
+[ f ] [
+ [ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
+ { fixnum+ } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ [ [ 1 ] [ 4 ] if ] ] [
+ [ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ [ [ 1 ] [ 2 ] if ] ] [
+ [ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ f ] [
+ [ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ 0 1000 [ 1 + dup >fixnum . ] times drop ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ 0 1000 [ 1 + ] times >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ f >fixnum ]
+ { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ [ >fixnum ] 2dip set-alien-unsigned-1 ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 123 >bignum bitand >fixnum ]
+ { >bignum fixnum>bignum bignum-bitand } inlined?
+] unit-test
+
+! Shifts
+[ t ] [
+ [
+ [ 0 ] 2dip { array } declare [
+ hashcode* >fixnum swap [
+ [ -2 shift ] [ 5 shift ] bi
+ + +
+ ] keep bitxor >fixnum
+ ] with each
+ ] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.partial-dispatch namespaces sequences sets
-accessors assocs words kernel memoize fry combinators
-combinators.short-circuit layouts alien.accessors
+USING: math math.intervals math.private math.partial-dispatch
+namespaces sequences sets accessors assocs words kernel memoize fry
+combinators combinators.short-circuit layouts alien.accessors
compiler.tree
compiler.tree.combinators
+compiler.tree.propagation.info
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
! ==>
! [ >fixnum ] bi@ fixnum+fast
+! Words where the low-order bits of the output only depends on the
+! low-order bits of the input. If the output is only used for its
+! low-order bits, then the word can be converted into a form that is
+! cheaper to compute.
{ + - * bitand bitor bitxor } [
[
t "modular-arithmetic" set-word-prop
] each-integer-derived-op
] each
-{ bitand bitor bitxor bitnot }
+{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
[ t "modular-arithmetic" set-word-prop ] each
+! Words that only use the low-order bits of their input. If the input
+! is a modular arithmetic word, then the input can be converted into
+! a form that is cheaper to compute.
{
- >fixnum
+ >fixnum bignum>fixnum float>fixnum
set-alien-unsigned-1 set-alien-signed-1
set-alien-unsigned-2 set-alien-signed-2
}
] when
[ t "low-order" set-word-prop ] each
-SYMBOL: modularize-values
+! Values which only have their low-order bits used. This set starts out
+! big and is gradually refined.
+SYMBOL: modular-values
: modular-value? ( value -- ? )
- modularize-values get key? ;
+ modular-values get key? ;
-: modularize-value ( value -- ) modularize-values get conjoin ;
+: modular-value ( value -- )
+ modular-values get conjoin ;
-GENERIC: maybe-modularize* ( value node -- )
+! Values which are known to be fixnums.
+SYMBOL: fixnum-values
-: maybe-modularize ( value -- )
- actually-defined-by [ value>> ] [ node>> ] bi
- over actually-used-by length 1 = [
- maybe-modularize*
- ] [ 2drop ] if ;
+: fixnum-value? ( value -- ? )
+ fixnum-values get key? ;
-M: #call maybe-modularize*
- dup word>> "modular-arithmetic" word-prop [
- [ modularize-value ]
- [ in-d>> [ maybe-modularize ] each ] bi*
- ] [ 2drop ] if ;
+: fixnum-value ( value -- )
+ fixnum-values get conjoin ;
-M: node maybe-modularize* 2drop ;
+GENERIC: compute-modular-candidates* ( node -- )
-GENERIC: compute-modularized-values* ( node -- )
+M: #push compute-modular-candidates*
+ [ out-d>> first ] [ literal>> ] bi
+ real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
-M: #call compute-modularized-values*
- dup word>> "low-order" word-prop
- [ in-d>> first maybe-modularize ] [ drop ] if ;
+: small-shift? ( interval -- ? )
+ 0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
-M: node compute-modularized-values* drop ;
+: modular-word? ( #call -- ? )
+ dup word>> { shift fixnum-shift bignum-shift } memq?
+ [ node-input-infos second interval>> small-shift? ]
+ [ word>> "modular-arithmetic" word-prop ]
+ if ;
-: compute-modularized-values ( nodes -- )
- [ compute-modularized-values* ] each-node ;
+: output-candidate ( #call -- )
+ out-d>> first [ modular-value ] [ fixnum-value ] bi ;
+
+: low-order-word? ( #call -- ? )
+ word>> "low-order" word-prop ;
+
+: input-candidiate ( #call -- )
+ in-d>> first modular-value ;
+
+M: #call compute-modular-candidates*
+ {
+ { [ dup modular-word? ] [ output-candidate ] }
+ { [ dup low-order-word? ] [ input-candidiate ] }
+ [ drop ]
+ } cond ;
+
+M: node compute-modular-candidates*
+ drop ;
+
+: compute-modular-candidates ( nodes -- )
+ H{ } clone modular-values set
+ H{ } clone fixnum-values set
+ [ compute-modular-candidates* ] each-node ;
+
+GENERIC: only-reads-low-order? ( node -- ? )
+
+: output-modular? ( #call -- ? )
+ out-d>> first modular-values get key? ;
+
+M: #call only-reads-low-order?
+ {
+ [ low-order-word? ]
+ [ { [ modular-word? ] [ output-modular? ] } 1&& ]
+ } 1|| ;
+
+M: node only-reads-low-order? drop f ;
+
+SYMBOL: changed?
+
+: only-used-as-low-order? ( value -- ? )
+ actually-used-by [ node>> only-reads-low-order? ] all? ;
+
+: (compute-modular-values) ( -- )
+ modular-values get keys [
+ dup only-used-as-low-order?
+ [ drop ] [ modular-values get delete-at changed? on ] if
+ ] each ;
+
+: compute-modular-values ( -- )
+ [ changed? off (compute-modular-values) changed? get ] loop ;
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
+M: #push optimize-modular-arithmetic*
+ dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
+ [ [ >fixnum ] change-literal ] when ;
+
: redundant->fixnum? ( #call -- ? )
- in-d>> first actually-defined-by value>> modular-value? ;
+ in-d>> first actually-defined-by
+ [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
+: should-be->fixnum? ( #call -- ? )
+ out-d>> first modular-value? ;
+
: optimize->integer ( #call -- nodes )
- dup out-d>> first actually-used-by dup length 1 = [
- first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
- [ drop { } ] when
- ] [ drop ] if ;
+ dup should-be->fixnum? [ \ >fixnum >>word ] when ;
MEMO: fixnum-coercion ( flags -- nodes )
+ ! flags indicate which input parameters are already known to be fixnums,
+ ! and don't need a coercion as a result.
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
+: modular-value-info ( #call -- alist )
+ [ in-d>> ] [ out-d>> ] bi append
+ fixnum <class-info> '[ _ ] { } map>assoc ;
+
: optimize-modular-op ( #call -- nodes )
dup out-d>> first modular-value? [
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
[
[
- [ actually-defined-by value>> modular-value? ]
+ [ actually-defined-by [ value>> modular-value? ] all? ]
[ fixnum eq? ]
bi* or
] 2map fixnum-coercion
] [ [ modular-variant ] change-word ] bi* suffix
] when ;
+: optimize-low-order-op ( #call -- nodes )
+ dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
+ [ ] [ in-d>> first ] [ info>> ] tri
+ [ drop fixnum <class-info> ] change-at
+ ] when ;
+
+: like->fixnum? ( #call -- ? )
+ word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
+
+: like->integer? ( #call -- ? )
+ word>> { >integer >bignum fixnum>bignum } memq? ;
+
M: #call optimize-modular-arithmetic*
- dup word>> {
- { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
- { [ dup \ >integer eq? ] [ drop optimize->integer ] }
- { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
- [ drop ]
+ {
+ { [ dup like->fixnum? ] [ optimize->fixnum ] }
+ { [ dup like->integer? ] [ optimize->integer ] }
+ { [ dup modular-word? ] [ optimize-modular-op ] }
+ { [ dup low-order-word? ] [ optimize-low-order-op ] }
+ [ ]
} cond ;
M: node optimize-modular-arithmetic* ;
: optimize-modular-arithmetic ( nodes -- nodes' )
- H{ } clone modularize-values set
- dup compute-modularized-values
- [ optimize-modular-arithmetic* ] map-nodes ;
+ dup compute-modular-candidates compute-modular-values
+ modular-values get assoc-empty? [
+ [ optimize-modular-arithmetic* ] map-nodes
+ ] unless ;
-IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
+IN: compiler.tree.normalization.tests
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
+++ /dev/null
-USING: compiler.tree.optimizer tools.test ;
-IN: compiler.tree.optimizer.tests
-
-
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
- pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+ pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
effect boa ;
M: curry cached-effect
: (value>quot) ( value-info -- quot )
dup class>> {
- { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
+ { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
-IN: compiler.tree.propagation.copy.tests
USING: compiler.tree.propagation.copy tools.test namespaces kernel
assocs ;
+IN: compiler.tree.propagation.copy.tests
H{ } clone copies set
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators
+sequences sequences.private words combinators memoize
combinators.short-circuit byte-arrays strings arrays layouts
cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: empty-set? ( info -- ? )
{
[ class>> null-class? ]
- [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+ [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
} 1|| ;
-: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+: min-value ( class -- n )
+ {
+ { fixnum [ most-negative-fixnum ] }
+ { array-capacity [ 0 ] }
+ [ drop -1/0. ]
+ } case ;
-: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+: max-value ( class -- n )
+ {
+ { fixnum [ most-positive-fixnum ] }
+ { array-capacity [ max-array-capacity ] }
+ [ drop 1/0. ]
+ } case ;
-: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+: class-interval ( class -- i )
+ {
+ { fixnum [ fixnum-interval ] }
+ { array-capacity [ array-capacity-interval ] }
+ [ drop full-interval ]
+ } case ;
: wrap-interval ( interval class -- interval' )
{
- { fixnum [ interval->fixnum ] }
- { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+ { [ over empty-interval eq? ] [ drop ] }
+ { [ over full-interval eq? ] [ nip class-interval ] }
+ { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
[ drop ]
- } case ;
+ } cond ;
: init-interval ( info -- info )
dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry combinators.smart hints
-locals
+combinators.short-circuit words namespaces continuations classes
+fry hints locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
compiler.tree.propagation.nodes ;
IN: compiler.tree.propagation.inlining
-! We count nodes up-front; if there are relatively few nodes,
-! we are more eager to inline
-SYMBOL: node-count
-
-: count-nodes ( nodes -- n )
- 0 swap [ drop 1+ ] each-node ;
-
-: compute-node-count ( nodes -- ) count-nodes node-count set ;
-
-! We try not to inline the same word too many times, to avoid
-! combinatorial explosion
-SYMBOL: inlining-count
-
! Splicing nodes
: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
dupd inlining-math-partial eliminate-dispatch ;
! Method body inlining
-SYMBOL: recursive-calls
-DEFER: (flat-length)
-
-: word-flat-length ( word -- n )
- {
- ! special-case
- { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
- ! not inline
- { [ dup inline? not ] [ drop 1 ] }
- ! recursive and inline
- { [ dup recursive-calls get key? ] [ drop 10 ] }
- ! inline
- [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
- } cond ;
-
-: (flat-length) ( seq -- n )
- [
- {
- { [ dup quotation? ] [ (flat-length) 2 + ] }
- { [ dup array? ] [ (flat-length) ] }
- { [ dup word? ] [ word-flat-length ] }
- [ drop 0 ]
- } cond
- ] sigma ;
-
-: flat-length ( word -- n )
- H{ } clone recursive-calls [
- [ recursive-calls get conjoin ]
- [ def>> (flat-length) 5 /i ]
- bi
- ] with-variable ;
-
-: classes-known? ( #call -- ? )
- in-d>> [
- value-info class>>
- [ class-types length 1 = ]
- [ union-class? not ]
- bi and
- ] any? ;
-
-: node-count-bias ( -- n )
- 45 node-count get [-] 8 /i ;
-
-: body-length-bias ( word -- n )
- [ flat-length ] [ inlining-count get at 0 or ] bi
- over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
-
-: inlining-rank ( #call word -- n )
- [
- [ classes-known? 2 0 ? ]
- [
- [ body-length-bias ]
- [ "specializer" word-prop 1 0 ? ]
- [ method-body? 1 0 ? ]
- tri
- node-count-bias
- loop-nesting get 0 or 2 *
- ] bi*
- ] sum-outputs ;
-
-: should-inline? ( #call word -- ? )
- dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-
SYMBOL: history
: already-inlined? ( obj -- ? ) history get memq? ;
: add-to-history ( obj -- ) history [ swap suffix ] change ;
-: remember-inlining ( word -- )
- [ inlining-count get inc-at ]
- [ add-to-history ]
- bi ;
-
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
[
- word remember-inlining
- [ ] [ count-nodes ] [ (propagate) ] tri
+ word add-to-history
+ dup (propagate)
] with-scope
- [ #call (>>body) ] [ node-count +@ ] bi* t
+ #call (>>body) t
] [ f ] if*
] if ;
-: inline-method-body ( #call word -- ? )
- 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
-
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
- [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
+ { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ dup method-body? ] [ inline-method-body ] }
+ { [ dup inline? ] [ inline-word ] }
[ 2drop f ]
} cond ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals
-math.parser math.order layouts words sequences sequences.private
+math.parser math.order math.functions layouts words sequences sequences.private
arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private
\ bitnot { integer } "input-classes" set-word-prop
-: ?change-interval ( info quot -- quot' )
- over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
+: real-op ( info quot -- quot' )
+ [
+ dup class>> real classes-intersect?
+ [ clone ] [ drop real <class-info> ] if
+ ] dip
+ change-interval ; inline
{ bitnot fixnum-bitnot bignum-bitnot } [
- [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
+ [ [ interval-bitnot ] real-op ] "outputs" set-word-prop
] each
-\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
+\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
+
+\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
: math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object }
dup name>> {
{
[ "alien-signed-" ?head ]
- [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+ [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
}
{
[ "alien-unsigned-" ?head ]
- [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+ [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
}
} cond
[ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
+[ bignum ] [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test
+
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
+[ t ] [ [ abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
+
[ V{ string } ] [
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
] unit-test
] unit-test
[ V{ fixnum } ] [
- [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+ [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ -1 } ] [
- [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
[ V{ 2 } ] [
] final-classes
] unit-test
+[ V{ f { } } ] [
+ [
+ T{ mixed-mutable-immutable f 3 { } }
+ [ x>> ] [ y>> ] bi
+ ] final-literals
+] unit-test
+
! Recursive propagation
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
] unit-test
: recursive-test-4 ( i n -- )
- 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
+ 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
: recursive-test-7 ( a -- b )
- dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
+ dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
] unit-test
GENERIC: iterate ( obj -- next-obj ? )
-M: fixnum iterate f ;
-M: array iterate first t ;
+M: fixnum iterate f ; inline
+M: array iterate first t ; inline
: dead-loop ( obj -- final-obj )
iterate [ dead-loop ] when ; inline recursive
] unit-test
GENERIC: bad-generic ( a -- b )
-M: fixnum bad-generic 1 fixnum+fast ;
+M: fixnum bad-generic 1 fixnum+fast ; inline
: bad-behavior ( -- b ) 4 bad-generic ; inline recursive
[ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
] unit-test
[ V{ bignum } ] [
- [ { bignum } declare dup 1- bitxor ] final-classes
+ [ { bignum } declare dup 1 - bitxor ] final-classes
] unit-test
[ V{ bignum integer } ] [
TUPLE: littledan-1 { a read-only } ;
-: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
: (littledan-3-test) ( x -- )
- length 1+ f <array> (littledan-3-test) ; inline recursive
+ length 1
+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+[ V{ 1 } ] [ [ { } length 1
+ f <array> length ] final-literals ] unit-test
! generalize-counter is not tight enough
[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
[ t ] [ [ foo new ] { new } inlined? ] unit-test
GENERIC: whatever ( x -- y )
-M: number whatever drop foo ;
+M: number whatever drop foo ; inline
[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
GENERIC: whatever2 ( x -- y )
-M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
-M: f whatever2 ;
+M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
+M: f whatever2 ; inline
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
H{ } clone copies set
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
- H{ } clone inlining-count set
- dup compute-node-count
dup (propagate) ;
-IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
math.intervals kernel math literals layouts ;
+IN: compiler.tree.propagation.recursive.tests
[ T{ interval f { 0 t } { 1/0. t } } ] [
T{ interval f { 1 t } { 1 t } }
M: #call propagate-before
dup word>> {
{ [ 2dup foldable-call? ] [ fold-call ] }
- { [ 2dup do-inlining ] [ 2drop ] }
+ { [ 2dup do-inlining ] [
+ [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
+ ] }
[
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
[ compute-constraints ]
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ 2dup length-accessor? ] [ nip length>> ] }
{ [ dup literal?>> ] [ literal>> literal-info-slot ] }
- [ [ 1- ] [ slots>> ] bi* ?nth ]
+ [ [ 1 - ] [ slots>> ] bi* ?nth ]
} cond [ object-info ] unless* ;
: rem-custom-inlining ( #call -- quot/f )
second value-info literal>> dup integer?
- [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+ [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
{
mod-integer-integer
in-d>> rem-custom-inlining
] "custom-inlining" set-word-prop
+: positive-fixnum? ( obj -- ? )
+ { [ fixnum? ] [ 0 >= ] } 1&& ;
+
+: simplify-bitand? ( value -- ? )
+ value-info literal>> positive-fixnum? ;
+
{
bitand-integer-integer
bitand-integer-fixnum
bitand
} [
[
- in-d>> second value-info >literal< [
- 0 most-positive-fixnum between?
- [ [ >fixnum ] bi@ fixnum-bitand ] f ?
- ] when
+ {
+ {
+ [ dup in-d>> first simplify-bitand? ]
+ [ drop [ >fixnum fixnum-bitand ] ]
+ }
+ {
+ [ dup in-d>> second simplify-bitand? ]
+ [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
+ }
+ [ drop f ]
+ } cond
] "custom-inlining" set-word-prop
] each
} 1&& ;
: lookup-table-seq ( assoc -- table )
- [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+ [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
-IN: compiler.tree.recursive.tests
USING: tools.test kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.tree.recursive
compiler.tree.recursive.private ;
+IN: compiler.tree.recursive.tests
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
] curry contains-node? ;
: loop-test-1 ( a -- )
- dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+ dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree analyze-recursive
] unit-test
: loop-test-2 ( a b -- a' )
- dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+ dup [ 1 + loop-test-2 1 - ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree analyze-recursive
[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
-[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
\ No newline at end of file
+[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
-IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
+IN: compiler.tree.tuple-unboxing.tests
: test-unboxing ( quot -- )
build-tree
{ code } ;\r
\r
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
-: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;\r
-: next-code ( code -- ) [ 1+ ] change-code drop ;\r
+: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;\r
+: next-code ( code -- ) [ 1 + ] change-code drop ;\r
\r
:: all-patterns ( huff n -- seq )\r
n log2 huff size>> - :> free-bits\r
k swap - dup k! 0 >
]
[ ] produce swap suffix
- { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
}
: nth* ( n seq -- elt )
- [ length 1- swap - ] [ nth ] bi ;
+ [ length 1 - swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
- [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+ [ first2 '[ _ 1 - bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors tools.test compression.lzw ;
-IN: compression.lzw.tests
-IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
concurrency.mailboxes threads sequences accessors arrays\r
math.parser ;\r
+IN: concurrency.combinators.tests\r
\r
[ [ drop ] parallel-each ] must-infer\r
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as\r
\r
[ "1a" "4b" "3c" ] [\r
2\r
- { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave\r
+ { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave\r
[ number>string ] 3 parallel-napply\r
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread\r
] unit-test\r
: count-down ( count-down -- )\r
dup n>> dup zero?\r
[ count-down-already-done ]\r
- [ 1- >>n count-down-check ] if ;\r
+ [ 1 - >>n count-down-check ] if ;\r
\r
: await-timeout ( count-down timeout -- )\r
[ promise>> ] dip ?promise-timeout ?linked t assert= ;\r
-IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
io.files.temp io.directories arrays io.sockets system
combinators threads math sequences concurrency.messaging
continuations accessors prettyprint ;
FROM: concurrency.messaging => receive send ;
+IN: concurrency.distributed.tests
: test-node ( -- addrspec )
{
-IN: concurrency.exchangers.tests\r
USING: tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
FROM: sequences => 3append ;\r
+IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
[let |\r
-IN: concurrency.flags.tests\r
USING: tools.test concurrency.flags concurrency.combinators\r
kernel threads locals accessors calendar ;\r
+IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
[let | f [ <flag> ] |\r
-IN: concurrency.futures.tests\r
USING: concurrency.futures kernel tools.test threads ;\r
+IN: concurrency.futures.tests\r
\r
[ 50 ] [\r
[ 50 ] future ?future\r
-IN: concurrency.locks.tests\r
USING: tools.test concurrency.locks concurrency.count-downs\r
concurrency.messaging concurrency.mailboxes locals kernel\r
threads sequences calendar accessors ;\r
+IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
[let | v [ V{ } clone ]\r
<PRIVATE\r
\r
: add-reader ( lock -- )\r
- [ 1+ ] change-reader# drop ;\r
+ [ 1 + ] change-reader# drop ;\r
\r
: acquire-read-lock ( lock timeout -- )\r
over writer>>\r
writers>> notify-1 ;\r
\r
: remove-reader ( lock -- )\r
- [ 1- ] change-reader# drop ;\r
+ [ 1 - ] change-reader# drop ;\r
\r
: release-read-lock ( lock -- )\r
dup remove-reader\r
-IN: concurrency.mailboxes.tests\r
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
vectors sequences threads tools.test math kernel strings namespaces\r
continuations calendar destructors ;\r
+IN: concurrency.mailboxes.tests\r
\r
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
\r
[\r
<mailbox> 1 seconds mailbox-get-timeout\r
] [ wait-timeout? ] must-fail-with\r
-
\ No newline at end of file
+ \r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals fry ;\r
+IN: concurrency.mailboxes\r
\r
TUPLE: mailbox threads data disposed ;\r
\r
-IN: concurrency.promises.tests\r
USING: vectors concurrency.promises kernel threads sequences\r
tools.test ;\r
+IN: concurrency.promises.tests\r
\r
[ V{ 50 50 50 } ] [\r
0 <vector>\r
: acquire-timeout ( semaphore timeout -- )\r
over count>> zero?\r
[ dupd wait-to-acquire ] [ drop ] if\r
- [ 1- ] change-count drop ;\r
+ [ 1 - ] change-count drop ;\r
\r
: acquire ( semaphore -- )\r
f acquire-timeout ;\r
\r
: release ( semaphore -- )\r
- [ 1+ ] change-count\r
+ [ 1 + ] change-count\r
threads>> notify-1 ;\r
\r
:: with-semaphore-timeout ( semaphore timeout quot -- )\r
-IN: cords.tests
USING: cords strings tools.test kernel sequences ;
+IN: cords.tests
[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.numbers ;
-IN: core-foundation.numbers.tests
: (reset-timer) ( timer counter -- )
yield {
{ [ dup 0 = ] [ now ((reset-timer)) ] }
- { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
+ { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
{ [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
[ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
} cond ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.utilities ;
-IN: core-foundation.utilities.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-graphics.types ;
-IN: core-graphics.types.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.fonts ;
-IN: core-text.fonts.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.utilities ;
-IN: core-text.utilities.tests
-IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ;
FROM: cpu.ppc.assembler => B ;
+IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
! key = class\r
5 4 MR\r
! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1- bootstrap-cell * ANDI\r
+ 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
! cache += array-start-offset\r
3 3 array-start-offset ADDI\r
! cache += key\r
temp dst 1 bignum@ STW
! Compute sign
temp src MR
- temp temp cell-bits 1- SRAWI
+ temp temp cell-bits 1 - SRAWI
temp temp 1 ANDI
! Store sign
temp dst 2 bignum@ STW
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
-: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
+: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap c-type-rep reg-class-of {
temp2 temp1 MOV
bootstrap-cell 8 = [ temp2 1 SHL ] when
! key &= cache.length - 1
- temp2 mega-cache-size get 1- bootstrap-cell * AND
+ temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
temp0 array-start-offset ADD
! cache += key
! make a copy
mod-arg div-arg MOV
! sign-extend
- mod-arg bootstrap-cell-bits 1- SAR
+ mod-arg bootstrap-cell-bits 1 - SAR
! divide
temp3 IDIV ;
-IN: cpu.x86.features.tests
USING: cpu.x86.features tools.test kernel sequences math system ;
+IN: cpu.x86.features.tests
cpu x86? [
[ t ] [ sse2? { t f } member? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
-] when
\ No newline at end of file
+] when
dst 3 bignum@ src MOV
! Compute sign
temp src MOV
- temp cell-bits 1- SAR
+ temp cell-bits 1 - SAR
temp 1 AND
! Store sign
dst 2 bignum@ temp MOV
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
- [ 1+ ] change-n drop ;
+ [ 1 + ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? )
[ n>> ] [ max>> ] bi < ;
M: random-id-generator eval-generator ( singleton -- obj )
drop
system-random-generator get [
- 63 [ random-bits ] keep 1- set-bit
+ 63 [ random-bits ] keep 1 - set-bit
] with-random ;
: interval-comparison ( ? str -- str )
} define-persistent
[ bignum-test drop-table ] ignore-errors
[ ] [ bignum-test ensure-table ] unit-test
- [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
+ [ ] [ 63 2^ 1 - dup dup <bignum-test> insert-tuple ] unit-test ;
! sqlite only
! [ T{ bignum-test f 1
-IN: debugger.tests\r
USING: debugger kernel continuations tools.test ;\r
+IN: debugger.tests\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
\r
[ f ] [ { } vm-error? ] unit-test\r
-[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
+[ f ] [ { "A" "B" } vm-error? ] unit-test\r
error-continuation get name>> assoc-stack ;
: :res ( n -- * )
- 1- restarts get-global nth f restarts set-global restart ;
+ 1 - restarts get-global nth f restarts set-global restart ;
: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: restart. ( restart n -- )
[
- 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
+ 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
- "Maximum: " write fourth 1- . ;
+ "Maximum: " write fourth 1 - . ;
: c-string-error. ( obj -- )
"Cannot convert to C string: " write third . ;
"SIGUSR1" "SIGUSR2"
}
-: signal-name ( n -- str/f ) 1- signal-names ?nth ;
+: signal-name ( n -- str/f ) 1 - signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test definitions.icons ;
-IN: definitions.icons.tests
TUPLE: hey value ;
C: <hey> hey
-CONSULT: alpha hey value>> 1+ ;
-CONSULT: beta hey value>> 1- ;
+CONSULT: alpha hey value>> 1 + ;
+CONSULT: beta hey value>> 1 - ;
[ 2 ] [ 1 <hey> one ] unit-test
[ 2 ] [ 1 <hey> two ] unit-test
-IN: disjoint-sets.testes
USING: tools.test disjoint-sets namespaces slots.private ;
+IN: disjoint-sets.testes
SYMBOL: +blah+
-405534154 +blah+ 1 set-slot
ranks>> at ; inline
: inc-rank ( a disjoint-set -- )
- ranks>> [ 1+ ] change-at ; inline
+ ranks>> [ 1 + ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
-IN: documents.tests
USING: documents documents.private accessors sequences
namespaces tools.test make arrays kernel fry ;
+IN: documents.tests
! Tests
[ drop ] [ doc-line length ] 2bi 2array ;
: doc-lines ( from to document -- slice )
- [ 1+ ] [ value>> ] bi* <slice> ;
+ [ 1 + ] [ value>> ] bi* <slice> ;
: start-on-line ( from line# document -- n1 )
drop over first =
[ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
: last-line# ( document -- line )
- value>> length 1- ;
+ value>> length 1 - ;
CONSTANT: doc-start { 0 0 }
over length 1 = [
nip first2
] [
- first swap length 1- + 0
+ first swap length 1 - + 0
] if
] dip last length + 2array ;
0 swap [ append ] change-nth ;
: append-last ( str seq -- )
- [ length 1- ] keep [ prepend ] change-nth ;
+ [ length 1 - ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ;
: (set-doc-range) ( doc-lines from to lines -- changed-lines )
[ prepare-insert ] 3keep
- [ [ first ] bi@ 1+ ] dip
+ [ [ first ] bi@ 1 + ] dip
replace-slice ;
: entire-doc ( document -- start end document )
: prev ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ pick { 0 0 } = ] [ 2drop ] }
- { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
+ { [ pick second zero? ] [ drop [ first 1 - ] dip line-end ] }
[ call ]
} cond ; inline
: next ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
- { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
+ { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] }
[ call ]
} cond ; inline
M: one-word-elt prev-elt
drop
- [ [ 1- ] dip f prev-word ] modify-col ;
+ [ [ 1 - ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt
drop
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
+ [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ]
prev ;
M: word-elt next-elt
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.macvim
: macvim ( file line -- )
-IN: eval.tests
USING: eval tools.test ;
+IN: eval.tests
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
parse-paragraph paragraph boa ;
: cut-half-slice ( string i -- before after-slice )
- [ head ] [ 1+ short tail-slice ] 2bi ;
+ [ head ] [ 1 + short tail-slice ] 2bi ;
: find-cut ( string quot -- before after delimiter )
dupd find
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: calendar kernel formatting tools.test ;
-
IN: formatting.tests
[ "%s" printf ] must-infer
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: accessors arrays assocs calendar combinators fry kernel
generalizations io io.streams.string macros math math.functions
math.parser peg.ebnf quotations sequences splitting strings
unicode.categories unicode.case vectors combinators.smart ;
-
IN: formatting
<PRIVATE
: fix-sign ( string -- string )
dup CHAR: 0 swap index 0 =
[ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
- [ dup 1- rot dup [ nth ] dip swap
+ [ dup 1 - rot dup [ nth ] dip swap
{
- { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
- { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] }
[ drop swap drop ]
} case
] [ drop ] if
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
- 10 swap ^ [ * round ] keep / ; inline
+ 10^ [ * round ] keep / ; inline
: >exp ( x -- exp base )
[
abs 0 swap
[ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
[ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip ]
- [ 10.0 * [ 1- ] dip ] if
+ [ 10.0 / [ 1 + ] dip ]
+ [ 10.0 * [ 1 - ] dip ] if
] while
] keep 0 < [ neg ] when ;
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
- [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1 + >fixnum ] if ;
: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
-IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
sequences eval accessors ;
+IN: fry.tests
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
- empty? [ >r/r>-in-fry-error ] unless ;
+ [ >r/r>-in-fry-error ] unless-empty ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
check-fry
[ [ deep-fry ] each ] [ ] make
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
- { _ } split [ spread>quot ] [ length 1- ] bi ;
+ { _ } split [ spread>quot ] [ length 1 - ] bi ;
PRIVATE>
-IN: functors.tests
USING: functors tools.test math words kernel multiline parser
io.streams.string generic ;
+IN: functors.tests
<<
+++ /dev/null
-USING: furnace.auth tools.test ;
-IN: furnace.auth.tests
-
+++ /dev/null
-IN: furnace.auth.features.edit-profile.tests
-USING: tools.test furnace.auth.features.edit-profile ;
-
-
+++ /dev/null
-IN: furnace.auth.features.recover-password
-USING: tools.test furnace.auth.features.recover-password ;
-
-
+++ /dev/null
-IN: furnace.auth.features.registration.tests
-USING: tools.test furnace.auth.features.registration ;
-
-
+++ /dev/null
-IN: furnace.auth.login.tests\r
-USING: tools.test furnace.auth.login ;\r
-\r
-\r
USING: accessors namespaces kernel combinators.short-circuit
db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
-
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
-IN: furnace.auth.providers.assoc.tests\r
USING: furnace.actions furnace.auth furnace.auth.providers \r
furnace.auth.providers.assoc furnace.auth.login\r
tools.test namespaces accessors kernel ;\r
+IN: furnace.auth.providers.assoc.tests\r
\r
<action> "Test" <login-realm>\r
<users-in-memory> >>users\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: furnace.auth.providers.assoc\r
USING: accessors assocs kernel furnace.auth.providers ;\r
+IN: furnace.auth.providers.assoc\r
\r
TUPLE: users-in-memory assoc ;\r
\r
-IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
furnace.auth\r
furnace.auth.login\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files io.files.temp io.directories accessors kernel ;\r
+IN: furnace.auth.providers.db.tests\r
\r
<action> "test" <login-realm> realm set\r
\r
+++ /dev/null
-IN: furnace.db.tests
-USING: tools.test furnace.db ;
-
-
-IN: furnace.tests
USING: http http.server.dispatchers http.server.responses
http.server furnace furnace.utilities tools.test kernel
namespaces accessors io.streams.string urls xml.writer ;
+IN: furnace.tests
+
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
-IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
accessors io.sockets io.servers.connection prettyprint\r
io.streams.string io.files io.files.temp io.directories\r
splitting destructors sequences db db.tuples db.sqlite\r
continuations urls math.parser furnace furnace.utilities ;\r
+IN: furnace.sessions.tests\r
\r
: with-session ( session quot -- )\r
[\r
\r
M: foo call-responder*\r
2drop\r
- "x" [ 1+ ] schange\r
+ "x" [ 1 + ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
: url-responder-mock-test ( -- string )\r
\r
[ 9 ] [ "x" sget sq ] unit-test\r
\r
- [ ] [ "x" [ 1- ] schange ] unit-test\r
+ [ ] [ "x" [ 1 - ] schange ] unit-test\r
\r
[ 4 ] [ "x" sget sq ] unit-test\r
\r
+USING: ui game-input tools.test kernel system threads calendar
+combinators.short-circuit ;
IN: game-input.tests
-USING: ui game-input tools.test kernel system threads calendar ;
-os windows? os macosx? or [
+os { [ windows? ] [ macosx? ] } 1|| [
[ ] [ open-game-input ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
-] when
\ No newline at end of file
+] when
game-input-opened? [
(open-game-input)
] unless
- game-input-opened [ 1+ ] change-global
+ game-input-opened [ 1 + ] change-global
reset-mouse ;
: close-game-input ( -- )
game-input-opened [
dup zero? [ game-input-not-open ] when
- 1-
+ 1 -
] change-global
game-input-opened? [
(close-game-input)
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
: record-button ( state hid-value element -- )
- [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement {
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
- 1- [ + ] n*quot ;
+ 1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
- [ 1- swap bounds-check 2drop ]
+ [ 1 - swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
- 1- [ dup ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
dup 1 + '[ _ npick ] n*quot ;
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
- 1- [ ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ ] [ '[ _ dip swap ] ] repeat ;
MACRO: -nrot ( n -- )
- 1- [ ] [ '[ swap _ dip ] ] repeat ;
+ 1 - [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
- 1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
+ 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
-IN: globs.tests
USING: tools.test globs ;
+IN: globs.tests
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-M: chunking-seq like drop { } like ;
+M: chunking-seq like drop { } like ; inline
INSTANCE: chunking-seq sequence
MIXIN: subseq-chunking
-M: subseq-chunking nth group@ subseq ;
+M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
-M: slice-chunking nth group@ <slice> ;
+M: slice-chunking nth group@ <slice> ; inline
-M: slice-chunking nth-unsafe group@ slice boa ;
+M: slice-chunking nth-unsafe group@ slice boa ; inline
TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
M: abstract-groups set-length
- [ n>> * ] [ seq>> ] bi set-length ;
+ [ n>> * ] [ seq>> ] bi set-length ; inline
M: abstract-groups group@
- [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
+ [ seq>> length ] [ n>> ] bi - 1 + ; inline
M: abstract-clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
+ [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
M: abstract-clumps group@
- [ n>> over + ] [ seq>> ] bi ;
+ [ n>> over + ] [ seq>> ] bi ; inline
PRIVATE>
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
-: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
\ No newline at end of file
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
: right ( n -- m ) 1 shift 2 + ; inline
-: up ( n -- m ) 1- 2/ ; inline
+: up ( n -- m ) 1 - 2/ ; inline
: data-nth ( n heap -- entry )
data>> nth-unsafe ; inline
M: heap heap-delete ( entry heap -- )
[ entry>index ] keep
- 2dup heap-size 1- = [
+ 2dup heap-size 1 - = [
nip data-pop*
] [
[ nip data-pop ] 2keep
-IN: help.apropos.tests
USING: help.apropos tools.test ;
+IN: help.apropos.tests
[ ] [ "swp" apropos ] unit-test
-IN: help.crossref.tests
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 ;
+IN: help.crossref.tests
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
-IN: help.handbook.tests
USING: help tools.test ;
+IN: help.handbook.tests
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
{ $subsection "prettyprint" }
{ $subsection "inspector" }
{ $subsection "tools.annotations" }
+{ $subsection "tools.deprecation" }
{ $subsection "tools.inference" }
{ $heading "Browsing" }
{ $subsection "see" }
-IN: help.tests
USING: tools.test help kernel ;
+IN: help.tests
[ 3 throw ] must-fail
[ ] [ :help ] unit-test
-[ ] [ f print-topic ] unit-test
\ No newline at end of file
+[ ] [ f print-topic ] unit-test
-IN: help.html.tests
USING: help.html tools.test help.topics kernel ;
+IN: help.html.tests
[ ] [ "xml" >link help>html drop ] unit-test
-[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
\ No newline at end of file
+[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
-IN: help.vocabs.tests
USING: help.vocabs tools.test help.markup help vocabs ;
+IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
-[ ] [ "classes" vocab print-topic ] unit-test
\ No newline at end of file
+[ ] [ "classes" vocab print-topic ] unit-test
SYNTAX: HINTS:
scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ]
- [ parse-definition { } like "specializer" set-word-prop ] bi ;
+ [ subwords [ changed-definition ] each ]
+ [ parse-definition { } like "specializer" set-word-prop ] tri ;
! Default specializers
{ first first2 first3 first4 }
-IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
FROM: html.components => inspector ;
+IN: html.components.tests
[ ] [ begin-form ] unit-test
-IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
FROM: html.forms => values ;
+IN: html.forms.tests
: with-validation ( quot -- messages )
[
[ value ] dip '[
[
form [ clone ] change
- 1+ "index" set-value
+ 1 + "index" set-value
"value" set-value
@
] with-scope
[ value ] dip '[
[
begin-form
- 1+ "index" set-value
+ 1 + "index" set-value
from-object
@
] with-scope
M: template-lexer skip-word
[
{
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup nth CHAR: " = ] [ drop 1 + ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
[ f skip ]
} cond
USING: http.client http.client.private http tools.test
namespaces urls ;
+IN: http.client.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test http.client.post-data ;
-IN: http.client.post-data.tests
-IN: http.parsers.tests
USING: http http.parsers tools.test ;
+IN: http.parsers.tests
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
[ { T{ cookie { name "__s" } { value "12345567" } } } ]
[ "__s=12345567;" parse-cookie ]
-unit-test
\ No newline at end of file
+unit-test
-IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
+IN: http.server.redirection.tests
[
<request>
-IN: http.server.static.tests
USING: http.server.static tools.test xml.writer ;
+IN: http.server.static.tests
-[ ] [ "resource:basis" directory>html write-xml ] unit-test
\ No newline at end of file
+[ ] [ "resource:basis" directory>html write-xml ] unit-test
] with each^2 ;
: sign-extend ( bits v -- v' )
- swap [ ] [ 1- 2^ < ] 2bi
- [ -1 swap shift 1+ + ] [ drop ] if ;
+ swap [ ] [ 1 - 2^ < ] 2bi
+ [ -1 swap shift 1 + + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
0 :> k!
[
color ac-huff-table>> read1-jpeg-ac
- [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+ [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not
k 63 < and
] loop
[\r
alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip\r
[| oldkey oldval key val | ! Underneath is start\r
- oldkey 1+ key =\r
+ oldkey 1 + key =\r
oldval val = and\r
[ oldkey 2array oldval 2array , key ] unless\r
key val\r
: something ( array -- num )
{
- { [ dup 1+ 2array ] [ 3 * ] }
+ { [ dup 1 + 2array ] [ 3 * ] }
{ [ 3array ] [ + + ] }
} switch ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
-[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
-[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test
+[ 0 ] [ { 1 2 } [ [ 1 + 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1 + ] bi@ ] input<sequence ] undo ] unit-test
reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
-MACRO: switch ( quot-alist -- ) [switch] ;
\ No newline at end of file
+MACRO: switch ( quot-alist -- ) [switch] ;
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
: num-fds ( mx -- n )
- [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1 + ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
-IN: io.backend.windows.privileges.tests\r
USING: io.backend.windows.privileges tools.test ;\r
+IN: io.backend.windows.privileges.tests\r
\r
[ [ ] with-privileges ] must-infer\r
io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise accessors ;
+splitting continuations math.bitwise accessors init sets assocs ;
IN: io.backend.windows
+: win32-handles ( -- assoc )
+ \ win32-handles [ H{ } clone ] initialize-alien ;
+
+TUPLE: win32-handle < identity-tuple handle disposed ;
+
+M: win32-handle hashcode* handle>> hashcode* ;
+
: set-inherit ( handle ? -- )
- [ HANDLE_FLAG_INHERIT ] dip
+ [ handle>> HANDLE_FLAG_INHERIT ] dip
>BOOLEAN SetHandleInformation win32-error=0/f ;
-TUPLE: win32-handle handle disposed ;
-
: new-win32-handle ( handle class -- win32-handle )
- new swap [ >>handle ] [ f set-inherit ] bi ;
+ new swap >>handle
+ dup f set-inherit
+ dup win32-handles conjoin ;
: <win32-handle> ( handle -- win32-handle )
win32-handle new-win32-handle ;
+ERROR: disposing-twice ;
+
+: unregister-handle ( handle -- )
+ win32-handles delete-at*
+ [ t >>disposed drop ] [ disposing-twice ] if ;
+
M: win32-handle dispose* ( handle -- )
- handle>> CloseHandle drop ;
+ [ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ;
TUPLE: win32-file < win32-handle ptr ;
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
+ nip 1 - pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
SINGLETON: ascii
M: ascii encode-char
- 128 encode-if< ;
+ 128 encode-if< ; inline
M: ascii decode-char
- 128 decode-if< ;
\ No newline at end of file
+ 128 decode-if< ; inline
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
- n multiple rem dup 0 = [
- drop n
+ n multiple rem [
+ n
] [
multiple swap - n +
- ] if ;
+ ] if-zero ;
TUPLE: windows-file-info < file-info attributes ;
file-info ;
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
"DWORD" <c-object>
"DWORD" <c-object>
"DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
] if ;
: find-first-volume ( -- string handle )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> tuck ] keep
+ MAX_PATH 1 + [ <byte-array> tuck ] keep
FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
- [ [ 1- ] [ follow-link ] bi* (follow-links) ]
+ [ [ 1 - ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
- [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+ [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
GetLastError ERROR_ALREADY_EXISTS = not ;
: set-file-pointer ( handle length method -- )
- [ dupd d>w/w <uint> ] dip SetFilePointer
- INVALID_SET_FILE_POINTER = [
- CloseHandle "SetFilePointer failed" throw
- ] when drop ;
+ [ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
+ INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
HOOK: open-append os ( path -- win32-file )
"append-test" temp-file ascii file-contents
] unit-test
+[ "( scratchpad ) " ] [
+ console-vm "-run=listener" 2array
+ ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+] unit-test
+
+[ ] [
+ console-vm "-run=listener" 2array
+ ascii [ "USE: system 0 exit" print ] with-process-writer
+] unit-test
+[ ] [
+ <process>
+ console-vm "-run=listener" 2array >>command
+ "vocab:io/launcher/windows/nt/test/input.txt" >>stdin
+ try-process
+] unit-test
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
- swap ! handle
+ swap handle>> ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
- DUPLICATE_CLOSE_SOURCE ! options
+ 0 ! options
DuplicateHandle win32-error=0/f
- ] keep *void* ;
+ ] keep *void* <win32-handle> &dispose ;
! /dev/null simulation
: null-input ( -- pipe )
- (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
+ (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
: null-output ( -- pipe )
- (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
+ (pipe) [ in>> dispose ] [ out>> &dispose ] bi ;
: null-pipe ( mode -- pipe )
{
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
+ CreateFile dup invalid-handle? <win32-file> &dispose ;
: redirect-append ( path access-mode create-mode -- handle )
[ path>> ] 2dip
dup 0 FILE_END set-file-pointer ;
: redirect-handle ( handle access-mode create-mode -- handle )
- 2drop handle>> duplicate-handle ;
+ 2drop ;
: redirect-stream ( stream access-mode create-mode -- handle )
- [ underlying-handle handle>> ] 2dip redirect-handle ;
+ [ underlying-handle ] 2dip redirect-handle ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick win32-file? ] [ redirect-handle ] }
[ redirect-stream ]
} cond
- dup [ dup t set-inherit ] when ;
+ dup [ dup t set-inherit handle>> ] when ;
: redirect-stdout ( process args -- handle )
drop
--- /dev/null
+USE: system 0 exit\r
: count-trailing-backslashes ( str n -- str n )
[ "\\" ?tail ] dip swap [
- 1+ count-trailing-backslashes
+ 1 + count-trailing-backslashes
] when ;
: fix-trailing-backslashes ( str -- str' )
TUPLE: dummy-monitor < monitor ;
M: dummy-monitor dispose
- drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+ drop dummy-monitor-disposed get [ 1 + ] change-i drop ;
M: mock-io-backend (monitor)
nip
over exists? [
dummy-monitor new-monitor
- dummy-monitor-created get [ 1+ ] change-i drop
+ dummy-monitor-created get [ 1 + ] change-i drop
] [
"Does not exist" throw
] if ;
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
+ [ length dup zero? [ drop { } ] [ 1
- <pipes> ] if ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
password [ B{ 0 } password! ] unless
[let | len [ password strlen ] |
- buf password len 1+ size min memcpy
+ buf password len 1 + size min memcpy
len
]
] alien-callback ;
[ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
- dup zero? [ drop ] [ gai_strerror throw ] if ;
+ [ gai_strerror throw ] unless-zero ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
\r
<PRIVATE\r
: levenshtein-step ( insert delete change same? -- next )\r
- 0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
+ 0 1 ? + [ [ 1 + ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
\r
:: loop-step ( i j matrix old new step -- )\r
- i j 1+ matrix nth nth ! insertion\r
- i 1+ j matrix nth nth ! deletion\r
+ i j 1 + matrix nth nth ! insertion\r
+ i 1 + j matrix nth nth ! deletion\r
i j matrix nth nth ! replace/retain\r
i old nth j new nth = ! same?\r
step call\r
- i 1+ j 1+ matrix nth set-nth ; inline\r
+ i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
[ drop 0 <array> ] with map ;\r
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1+ new length 1+ init call ] |\r
+ [let | matrix [ old length 1 + new length 1 + init call ] |\r
old length [| i |\r
new length\r
[| j | i j matrix old new step loop-step ] each\r
TUPLE: trace-state old new table i j ;\r
\r
: old-nth ( state -- elt )\r
- [ i>> 1- ] [ old>> ] bi nth ;\r
+ [ i>> 1 - ] [ old>> ] bi nth ;\r
\r
: new-nth ( state -- elt )\r
- [ j>> 1- ] [ new>> ] bi nth ;\r
+ [ j>> 1 - ] [ new>> ] bi nth ;\r
\r
: top-beats-side? ( state -- ? )\r
- [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]\r
- [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
+ [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth nth ]\r
+ [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
\r
: retained? ( state -- ? )\r
{\r
\r
: do-retain ( state -- state )\r
dup old-nth retain boa ,\r
- [ 1- ] change-i [ 1- ] change-j ;\r
+ [ 1 - ] change-i [ 1 - ] change-j ;\r
\r
: inserted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-insert ( state -- state )\r
- dup new-nth insert boa , [ 1- ] change-j ;\r
+ dup new-nth insert boa , [ 1 - ] change-j ;\r
\r
: deleted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-delete ( state -- state )\r
- dup old-nth delete boa , [ 1- ] change-i ;\r
+ dup old-nth delete boa , [ 1 - ] change-i ;\r
\r
: (trace-diff) ( state -- )\r
{\r
} cond ;\r
\r
: trace-diff ( old new table -- diff )\r
- [ ] [ first length 1- ] [ length 1- ] tri trace-state boa\r
+ [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa\r
[ (trace-diff) ] { } make reverse ;\r
PRIVATE>\r
\r
{ 9 } [
<linked-hash>
- { [ 3 * ] [ 1- ] } "first" pick set-at
- { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ { [ 3 * ] [ 1 - ] } "first" pick set-at
+ { [ [ 1 - ] bi@ ] [ 2 / ] } "second" pick set-at
4 6 pick values [ first call ] each
+ swap values <reversed> [ second call ] each
] unit-test
2 "by" pick set-at
3 "cx" pick set-at
>alist
-] unit-test
\ No newline at end of file
+] unit-test
cons>> car ;
M: lazy-take cdr ( lazy-take -- cdr )
- [ n>> 1- ] keep
+ [ n>> 1 - ] keep
cons>> cdr ltake ;
M: lazy-take nil? ( lazy-take -- ? )
C: lfrom-by lazy-from-by
: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
+ [ 1 + ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
n>> ;
[ index>> ] [ seq>> nth ] bi ;
M: sequence-cons cdr ( sequence-cons -- cdr )
- [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ;
+ [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
M: sequence-cons nil? ( sequence-cons -- ? )
drop f ;
] unit-test
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
- { 1 2 3 4 } sequence>list [ 1+ ] lmap
+ { 1 2 3 4 } sequence>list [ 1 + ] lmap
] unit-test
{ 15 } [
] if ; inline recursive
: llength ( list -- n )
- 0 [ drop 1+ ] foldl ;
+ 0 [ drop 1 + ] foldl ;
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
IN: scratchpad
<< CONSTANT: five 5 >>
-{ $[ five dup 1+ dup 2 + ] } .
+{ $[ five dup 1 + dup 2 + ] } .
"> "{ 5 6 8 }" }
} ;
IN: scratchpad
CONSTANT: five 5
-{ $ five $[ five dup 1+ dup 2 + ] } .
+{ $ five $[ five dup 1 + dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $code
":: counter ( -- )"
" [let | value! [ 0 ] |"
- " [ value 1+ dup value! ]"
- " [ value 1- dup value! ] ] ;"
+ " [ value 1 + dup value! ]"
+ " [ value 1 - dup value! ] ] ;"
}
"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
$nl
[ 5 ] [ 10 xyzzy ] unit-test
:: let*-test-1 ( a -- b )
- [let* | b [ a 1+ ]
- c [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
:: let*-test-2 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
:: let*-test-3 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
- c 1+ c! a b c 3array ] ;
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
+ c 1 + c! a b c 3array ] ;
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
[ 3 ] [ 3 [| | :> a! a ] call ] unit-test
-[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
+[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
over exists? [ move-file ] [ 2drop ] if ;\r
\r
: advance-log ( path n -- )\r
- [ 1- log# ] 2keep log# ?move-file ;\r
+ [ 1 - log# ] 2keep log# ?move-file ;\r
\r
: rotate-log ( service -- )\r
dup close-log\r
C: <bits> bits
: make-bits ( number -- bits )
- dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
+ [ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
-M: bits length length>> ;
+M: bits length length>> ; inline
-M: bits nth-unsafe number>> swap bit? ;
+M: bits nth-unsafe number>> swap bit? ; inline
INSTANCE: bits immutable-sequence
: unbits ( seq -- number )
- <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
+ <reversed> 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ;
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
-[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
+: test-1+ ( x -- y ) 1 + ;
+[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
CONSTANT: a 1
CONSTANT: b 2
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
-{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
+{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
parser ;
IN: math.complex.private
-M: real real-part ;
-M: real imaginary-part drop 0 ;
-M: complex real-part real>> ;
-M: complex imaginary-part imaginary>> ;
-M: complex absq >rect [ sq ] bi@ + ;
-M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
+M: real real-part ; inline
+M: real imaginary-part drop 0 ; inline
+M: complex real-part real>> ; inline
+M: complex imaginary-part imaginary>> ; inline
+M: complex absq >rect [ sq ] bi@ + ; inline
+M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline
: componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline
: complex= ( x y quot -- ? ) componentwise and ; inline
-M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
-M: complex number= [ number= ] complex= ;
+M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline
+M: complex number= [ number= ] complex= ; inline
: complex-op ( x y quot -- z ) componentwise rect> ; inline
-M: complex + [ + ] complex-op ;
-M: complex - [ - ] complex-op ;
+M: complex + [ + ] complex-op ; inline
+M: complex - [ - ] complex-op ; inline
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
: *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
-M: complex * [ *re - ] [ *im + ] 2bi rect> ;
+M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
: (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
-M: complex / [ / ] complex/ ;
-M: complex /f [ /f ] complex/ ;
-M: complex /i [ /i ] complex/ ;
-M: complex abs absq >float fsqrt ;
-M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
+M: complex / [ / ] complex/ ; inline
+M: complex /f [ /f ] complex/ ; inline
+M: complex /i [ /i ] complex/ ; inline
+M: complex abs absq >float fsqrt ; inline
+M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax
"Computing additive and multiplicative inverses:"
{ $subsection neg }
{ $subsection recip }
-"Incrementing, decrementing:"
-{ $subsection 1+ }
-{ $subsection 1- }
"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
"Tests:"
{ $subsection zero? }
{ $subsection between? }
+"Control flow:"
+{ $subsection if-zero }
+{ $subsection when-zero }
+{ $subsection unless-zero }
"Sign:"
{ $subsection sgn }
"Rounding:"
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+{ $subsection log10 }
"Raising a number to a power:"
{ $subsection ^ }
+{ $subsection 10^ }
"Converting between rectangular and polar form:"
{ $subsection abs }
{ $subsection absq }
{ $values { "x" number } { "y" number } }
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+HELP: log10
+{ $values { "x" number } { "y" number } }
+{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+
HELP: sqrt
{ $values { "x" number } { "y" number } }
{ $description "Square root function." } ;
{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
+HELP: 10^
+{ $values { "x" number } { "y" number } }
+{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ;
+
HELP: gcd
{ $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } }
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
- >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
+ >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
- dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
+ [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
: divisor? ( m n -- ? )
mod 0 = ;
+ERROR: non-trivial-divisor n ;
+
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
- [ "Non-trivial divisor found" throw ] if ; foldable
+ [ non-trivial-divisor ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [
GENERIC: absq ( x -- y ) foldable
-M: real absq sq ;
+M: real absq sq ; inline
: ~abs ( x y epsilon -- ? )
[ - abs ] dip < ;
GENERIC: exp ( x -- y )
-M: real exp fexp ;
+M: real exp fexp ; inline
M: complex exp >rect swap fexp swap polar> ;
GENERIC: log ( x -- y )
-M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
+M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
M: complex log >polar swap flog swap rect> ;
+: 10^ ( x -- y ) 10 swap ^ ; inline
+
+: log10 ( x -- y ) log 10 log / ; inline
+
GENERIC: cos ( x -- y ) foldable
M: complex cos
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real cos fcos ;
+M: real cos fcos ; inline
: sec ( x -- y ) cos recip ; inline
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real cosh fcosh ;
+M: real cosh fcosh ; inline
: sech ( x -- y ) cosh recip ; inline
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real sin fsin ;
+M: real sin fsin ; inline
: cosec ( x -- y ) sin recip ; inline
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real sinh fsinh ;
+M: real sinh fsinh ; inline
: cosech ( x -- y ) sinh recip ; inline
M: complex tan [ sin ] [ cos ] bi / ;
-M: real tan ftan ;
+M: real tan ftan ; inline
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
-M: real tanh ftanh ;
+M: real tanh ftanh ; inline
: cot ( x -- y ) tan recip ; inline
M: complex atan i* atanh i* ;
-M: real atan fatan ;
+M: real atan fatan ; inline
: asec ( x -- y ) recip acos ; inline
: round ( x -- y ) dup sgn 2 / + truncate ; inline
: floor ( x -- y )
- dup 1 mod dup zero?
- [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
+ dup 1 mod
+ [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: floor-to ( x step -- y )
- dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
+ [ [ / floor ] [ * ] bi ] unless-zero ;
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
{ $description "Computes the bitwise complement of the interval." } ;
HELP: points>interval
-{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } }
+{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } { "nan?" "true if the computation produced NaNs" } }
{ $description "Outputs the smallest interval containing all of the endpoints." }
;
0 1 (a,b) 0 1 [a,b] interval-subset?
] unit-test
+[ t ] [
+ full-interval -1/0. 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ -1/0. 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
+[ f ] [
+ full-interval 0 1/0. [a,b] interval-subset?
+] unit-test
+
+[ t ] [
+ 0 1/0. [a,b] full-interval interval-subset?
+] unit-test
+
[ f ] [
0 0 1 (a,b) interval-contains?
] unit-test
{ bitnot interval-bitnot }
{ abs interval-abs }
{ 2/ interval-2/ }
- { 1+ interval-1+ }
- { 1- interval-1- }
{ neg interval-neg }
}
"math.ratios.private" vocab [
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
+[ t ] [ full-interval interval-abs [0,inf] = ] unit-test
+
+[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test
+
! Test that commutative interval ops really are
: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
TUPLE: interval { from read-only } { to read-only } ;
+: closed-point? ( from to -- ? )
+ 2dup [ first ] bi@ number=
+ [ [ second ] both? ] [ 2drop f ] if ;
+
: <interval> ( from to -- interval )
- 2dup [ first ] bi@ {
- { [ 2dup > ] [ 2drop 2drop empty-interval ] }
- { [ 2dup number= ] [
- 2drop 2dup [ second ] both?
+ {
+ { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] }
+ { [ 2dup [ first ] bi@ number= ] [
+ 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
- [ 2drop interval boa ]
+ { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [
+ 2drop full-interval
+ ] }
+ [ interval boa ]
} cond ;
: open-point ( n -- endpoint ) f 2array ;
MEMO: fixnum-interval ( -- interval )
most-negative-fixnum most-positive-fixnum [a,b] ; inline
+MEMO: array-capacity-interval ( -- interval )
+ 0 max-array-capacity [a,b] ; inline
+
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
: interval>points ( int -- from to )
[ from>> ] [ to>> ] bi ;
-: points>interval ( seq -- interval )
- dup [ first fp-nan? ] any?
- [ drop [-inf,inf] ] [
- dup first
- [ [ endpoint-min ] reduce ]
- [ [ endpoint-max ] reduce ]
- 2bi <interval>
- ] if ;
+: points>interval ( seq -- interval nan? )
+ [ first fp-nan? not ] partition
+ [
+ [ [ ] [ endpoint-min ] map-reduce ]
+ [ [ ] [ endpoint-max ] map-reduce ] bi
+ <interval>
+ ]
+ [ empty? not ]
+ bi* ;
+
+: nan-ok ( interval nan? -- interval ) drop ; inline
+: nan-not-ok ( interval nan? -- interval ) [ drop full-interval ] when ; inline
: (interval-op) ( p1 p2 quot -- p3 )
[ [ first ] [ first ] [ call ] tri* ]
[ drop [ second ] both? ]
3bi 2array ; inline
-: interval-op ( i1 i2 quot -- i3 )
+: interval-op ( i1 i2 quot -- i3 nan? )
{
[ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
[ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
} cond ; inline
: interval+ ( i1 i2 -- i3 )
- [ [ + ] interval-op ] do-empty-interval ;
+ [ [ + ] interval-op nan-ok ] do-empty-interval ;
: interval- ( i1 i2 -- i3 )
- [ [ - ] interval-op ] do-empty-interval ;
+ [ [ - ] interval-op nan-ok ] do-empty-interval ;
: interval-intersect ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ drop ] }
{ [ over full-interval eq? ] [ drop ] }
{ [ dup full-interval eq? ] [ nip ] }
- [ [ interval>points 2array ] bi@ append points>interval ]
+ [ [ interval>points 2array ] bi@ append points>interval nan-not-ok ]
} cond ;
: interval-subset? ( i1 i2 -- ? )
0 swap interval-contains? ;
: interval* ( i1 i2 -- i3 )
- [ [ [ * ] interval-op ] do-empty-interval ]
+ [ [ [ * ] interval-op nan-ok ] do-empty-interval ]
[ [ interval-zero? ] either? ]
2bi [ 0 [a,a] interval-union ] when ;
[
[
[ interval-closure ] bi@
- [ shift ] interval-op
+ [ shift ] interval-op nan-not-ok
] interval-integer-op
] do-empty-interval ;
: interval-max ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
- [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
+ [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ;
: interval-min ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
- [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
+ [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ;
: interval-interior ( i1 -- i2 )
dup special-interval? [
} cond ; inline
: interval/ ( i1 i2 -- i3 )
- [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
+ [ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
: interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math
[
[
[ interval-closure ] bi@
- [ /i ] interval-op
+ [ /i ] interval-op nan-not-ok
] interval-integer-op
] interval-division-op
] do-empty-interval ;
: interval/f ( i1 i2 -- i3 )
- [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
+ [ [ [ /f ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
: (interval-abs) ( i1 -- i2 )
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
{
{ [ dup empty-interval eq? ] [ ] }
{ [ dup full-interval eq? ] [ drop [0,inf] ] }
- { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
- [ (interval-abs) points>interval ]
+ { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] }
+ [ (interval-abs) points>interval nan-not-ok ]
} cond ;
+: interval-absq ( i1 -- i2 )
+ interval-abs interval-sq ;
+
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
[ nip (rem-range) ]
} cond ;
-: interval->fixnum ( i1 -- i2 )
- {
- { [ dup empty-interval eq? ] [ ] }
- { [ dup full-interval eq? ] [ drop fixnum-interval ] }
- { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
- [ ]
- } cond ;
-
: interval-bitand-pos ( i1 i2 -- ? )
[ to>> first ] bi@ min 0 swap [a,b] ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
[ first-col ] keep
- dup 1+ rows-from clear-col ;
+ dup 1 + rows-from clear-col ;
: find-row ( row# quot -- i elt )
[ rows-from ] dip find ; inline
: (echelon) ( col# row# -- )
over cols < over rows < and [
- 2dup pivot-row [ over do-row 1+ ] when*
- [ 1+ ] dip (echelon)
+ 2dup pivot-row [ over do-row 1 + ] when*
+ [ 1 + ] dip (echelon)
] [
2drop
] if ;
CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
: bit-pos ( n -- byte/f mask/f )
- 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
+ 30 /mod masks nth-unsafe [ drop f f ] when-zero ;
: marked-unsafe? ( n arr -- ? )
[ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
: marked-prime? ( n arr -- ? )
2dup upper-bound 2 swap between? [ bounds-error ] unless
- over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
\ No newline at end of file
+ over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
: count-factor ( n d -- n' c )
[ 1 ] 2dip [ /i ] keep
- [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
+ [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop
swap ;
: write-factor ( n d -- n' d' )
: totient ( n -- t )
{
{ [ dup 2 < ] [ drop 0 ] }
- [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
+ [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ]
} cond ; foldable
: divisors ( n -- seq )
: <range> ( a b step -- range )
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
-M: range length ( seq -- n )
- length>> ;
+M: range length ( seq -- n ) length>> ; inline
-M: range nth-unsafe ( n range -- obj )
- [ step>> * ] keep from>> + ;
+M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
! For ranges with many elements, the default element-wise methods
! sequences define are unsuitable because they're O(n)
[ 3 ] [ 10/3 truncate ] unit-test
[ -3 ] [ -10/3 truncate ] unit-test
-[ -1/2 ] [ 1/2 1- ] unit-test
-[ 3/2 ] [ 1/2 1+ ] unit-test
+[ -1/2 ] [ 1/2 1 - ] unit-test
+[ 3/2 ] [ 1/2 1 + ] unit-test
[ 1.0 ] [ 0.5 1/2 + ] unit-test
[ 1.0 ] [ 1/2 0.5 + ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private math math.functions math.private ;
+USING: accessors kernel kernel.private math math.functions
+math.private sequences summary ;
IN: math.ratios
: 2>fraction ( a/b c/d -- a c b d )
PRIVATE>
+ERROR: division-by-zero x ;
+
+M: division-by-zero summary
+ drop "Division by zero" ;
+
M: integer /
- dup zero? [
- "Division by zero" throw
+ [
+ division-by-zero
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip [ /i ] curry bi@ fraction>
- ] if ;
+ ] if-zero ;
M: ratio hashcode*
nip >fraction [ hashcode ] bi@ bitxor ;
M: ratio >bignum >fraction /i >bignum ;
M: ratio >float >fraction /f ;
-M: ratio numerator numerator>> ;
-M: ratio denominator denominator>> ;
+M: ratio numerator numerator>> ; inline
+M: ratio denominator denominator>> ; inline
M: ratio < scale < ;
M: ratio <= scale <= ;
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
dup bytes>> length 256 < [ fill-bytes ] when ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
- dupd [ length ] bi@ 1- - short cut-slice swap ;
+ dupd [ length ] bi@ 1 - - short cut-slice swap ;
: dump-until-separator ( multipart -- multipart )
dup
\r
3 <model> "x" set\r
"x" get [ 2 * ] <arrow> dup "z" set\r
-[ 1+ ] <arrow> "y" set\r
+[ 1
+ ] <arrow> "y" set
\r [ ] [ "y" get activate-model ] unit-test\r
[ t ] [ "z" get "x" get connections>> memq? ] unit-test\r
[ 7 ] [ "y" get value>> ] unit-test\r
M: model model-activated drop ;
: ref-model ( model -- n )
- [ 1+ ] change-ref ref>> ;
+ [ 1 + ] change-ref ref>> ;
: unref-model ( model -- n )
- [ 1- ] change-ref ref>> ;
+ [ 1 - ] change-ref ref>> ;
: activate-model ( model -- )
dup ref-model 1 = [
\r
TUPLE: an-observer { i integer } ;\r
\r
-M: an-observer model-changed nip [ 1+ ] change-i drop ;\r
+M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
[let* | m1 [ 1 <model> ]\r
o1 i>>\r
o2 i>>\r
]\r
-] unit-test
\ No newline at end of file
+] unit-test\r
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax strings ;
IN: multiline
HELP: STRING:
""
} ;
+HELP: HEREDOC:
+{ $syntax "HEREDOC: marker\n...text...\nmarker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $warning "Whitespace is significant." }
+{ $examples
+ { $example "USING: multiline prettyprint ;"
+ "HEREDOC: END\nx\nEND\n."
+ "\"x\\n\""
+ }
+ { $example "USING: multiline prettyprint sequences ;"
+ "2 5 HEREDOC: zap\nfoo\nbar\nzap\nsubseq ."
+ "\"o\\nb\""
+ }
+} ;
+
+HELP: DELIMITED:
+{ $syntax "DELIMITED: marker\n...text...\nmarker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $examples
+ { $example "USING: multiline prettyprint ;"
+ "DELIMITED: factor blows my mind"
+"whoafactor blows my mind ."
+ "\"whoa\""
+ }
+} ;
+
{ POSTPONE: <" POSTPONE: STRING: } related-words
HELP: parse-multiline-string
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
{ $subsection POSTPONE: <" }
+{ $subsection POSTPONE: HEREDOC: }
+{ $subsection POSTPONE: DELIMITED: }
"Multiline comments:"
{ $subsection POSTPONE: /* }
"Writing new multiline parsing words:"
-USING: multiline tools.test ;
+USING: accessors eval multiline tools.test ;
IN: multiline.tests
STRING: test-it
[ "\nhi" ] [ <"
hi"> ] unit-test
+
+
+! HEREDOC:
+
+[ "foo\nbar\n" ] [ HEREDOC: END
+foo
+bar
+END
+] unit-test
+
+[ "" ] [ HEREDOC: END
+END
+] unit-test
+
+[ " END\n" ] [ HEREDOC: END
+ END
+END
+] unit-test
+
+[ "\n" ] [ HEREDOC: END
+
+END
+] unit-test
+
+[ "x\n" ] [ HEREDOC: END
+x
+END
+] unit-test
+
+[ "x\n" ] [ HEREDOC: END
+x
+END
+] unit-test
+
+[ "xyz \n" ] [ HEREDOC: END
+xyz
+END
+] unit-test
+
+[ "} ! * # \" «\n" ] [ HEREDOC: END
+} ! * # " «
+END
+] unit-test
+
+[ 21 "foo\nbar\n" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
+foo
+bar
+X
+HEREDOC: END
+ HEREDOC: FOO
+ FOO
+END
+22 ] unit-test
+
+[ "lol\n xyz\n" ]
+[
+HEREDOC: xyz
+lol
+ xyz
+xyz
+] unit-test
+
+
+[ "lol" ]
+[ DELIMITED: aol
+lolaol ] unit-test
+
+[ "whoa" ]
+[ DELIMITED: factor blows my mind
+whoafactor blows my mind ] unit-test
quotations math accessors locals ;
IN: multiline
+ERROR: bad-heredoc identifier ;
+
<PRIVATE
: next-line-text ( -- str )
lexer get dup next-line line-text>> ;
<PRIVATE
-:: (parse-multiline-string) ( i end -- j )
+:: (scan-multiline-string) ( i end -- j )
lexer get line-text>> :> text
text [
end text i start* [| j |
] [
text i short tail % CHAR: \n ,
lexer get next-line
- 0 end (parse-multiline-string)
+ 0 end (scan-multiline-string)
] if*
] [ end unexpected-eof ] if ;
-PRIVATE>
-
-: parse-multiline-string ( end-text -- str )
+:: (parse-multiline-string) ( end-text skip-n-chars -- str )
[
lexer get
- [ 1+ swap (parse-multiline-string) ]
+ [ skip-n-chars + end-text (scan-multiline-string) ]
change-column drop
] "" make ;
+: rest-of-line ( -- seq )
+ lexer get [ line-text>> ] [ column>> ] bi tail ;
+
+:: advance-same-line ( text -- )
+ lexer get [ text length + ] change-column drop ;
+
+:: (parse-til-line-begins) ( begin-text -- )
+ lexer get still-parsing? [
+ lexer get line-text>> begin-text sequence= [
+ begin-text advance-same-line
+ ] [
+ lexer get line-text>> % "\n" %
+ lexer get next-line
+ begin-text (parse-til-line-begins)
+ ] if
+ ] [
+ begin-text bad-heredoc
+ ] if ;
+
+: parse-til-line-begins ( begin-text -- seq )
+ [ (parse-til-line-begins) ] "" make ;
+
+PRIVATE>
+
+: parse-multiline-string ( end-text -- str )
+ 1 (parse-multiline-string) ;
+
SYNTAX: <"
"\">" parse-multiline-string parsed ;
"\"}" parse-multiline-string parsed ;
SYNTAX: /* "*/" parse-multiline-string drop ;
+
+SYNTAX: HEREDOC:
+ lexer get skip-blank
+ rest-of-line
+ lexer get next-line
+ parse-til-line-begins parsed ;
+
+SYNTAX: DELIMITED:
+ lexer get skip-blank
+ rest-of-line
+ lexer get next-line
+ 0 (parse-multiline-string) parsed ;
: gl-function-number ( -- n )
+gl-function-number-counter+ get-global
- dup 1+ +gl-function-number-counter+ set-global ;
+ dup 1 + +gl-function-number-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
dup zero? [
2drop epsilon
] [
- [ exactly-n ] [ 1- at-most-n ] 2bi 2choice
+ [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice
] if ;
: at-least-n ( parser n -- parser' )
: next-id ( -- n )
#! Return the next unique id for a parser
id get-global [
- dup 1+ id set-global
+ dup 1 + id set-global
] [
1 id set-global 0
] if* ;
IN: persistent.hashtables.config
: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
-: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
-: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline
+: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable
+: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline
{
{ [ 2dup root>> eq? ] [ nip ] }
{ [ over not ] [ 2drop T{ persistent-hash } ] }
- [ count>> 1- persistent-hash boa ]
+ [ count>> 1 - persistent-hash boa ]
} cond ;
M: persistent-hash >alist [ root>> >alist% ] { } make ;
persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.bitmap
-: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
+: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
[let* | shift [ bitmap-node shift>> ]
[ 1array ] dip node boa ;
: 2node ( first second -- node )
- [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+ [ 2array ] [ drop level>> 1 + ] 2bi node boa ;
: new-child ( new-child node -- node' expansion/f )
dup full? [ tuck level>> 1node ] [ node-add f ] if ;
: new-last ( val seq -- seq' )
- [ length 1- ] keep new-nth ;
+ [ length 1 - ] keep new-nth ;
: node-set-last ( child node -- node' )
clone [ new-last ] change-children ;
clone
dup tail>> full?
[ ppush-new-tail ] [ ppush-tail ] if
- [ 1+ ] change-count ;
+ [ 1 + ] change-count ;
: node-set-nth ( val i node -- node' )
clone [ new-nth ] change-children ;
clone
dup tail>> children>> length 1 >
[ ppop-tail ] [ ppop-new-tail ] if
- ] dip 1- >>count
+ ] dip 1 - >>count
]
} case ;
] [
CHAR: y = [
over zero?
- [ 2drop t ] [ [ 1- ] dip consonant? not ] if
+ [ 2drop t ] [ [ 1 - ] dip consonant? not ] if
] [
2drop t
] if
: skip-vowels ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
+ 2dup consonant? [ [ 1 + ] dip skip-vowels ] unless
] when ;
: skip-consonants ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-consonants ] when
+ 2dup consonant? [ [ 1 + ] dip skip-consonants ] when
] when ;
: (consonant-seq) ( n i str -- n )
skip-vowels
2dup bounds-check? [
- [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
+ [ 1 + ] [ 1 + ] [ ] tri* skip-consonants [ 1 + ] dip
(consonant-seq)
] [
2drop
over 1 < [
2drop f
] [
- 2dup nth [ over 1- over nth ] dip = [
+ 2dup nth [ over 1 - over nth ] dip = [
consonant?
] [
2drop f
{ [ "bl" ?tail ] [ "ble" append ] }
{ [ "iz" ?tail ] [ "ize" append ] }
{
- [ dup length 1- over double-consonant? ]
+ [ dup length 1 - over double-consonant? ]
[ dup "lsz" last-is? [ but-last-slice ] unless ]
}
{
: ll->l ( str -- newstr )
{
{ [ dup last CHAR: l = not ] [ ] }
- { [ dup length 1- over double-consonant? not ] [ ] }
+ { [ dup length 1 - over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
} cond ;
] if
] if ; inline
-: tuple>assoc ( tuple -- assoc )
- [ class all-slots ] [ tuple-slots ] bi zip
+: filter-tuple-assoc ( slot,value -- name,value )
[ [ initial>> ] dip = not ] assoc-filter
[ [ name>> ] dip ] assoc-map ;
+: tuple>assoc ( tuple -- assoc )
+ [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
+
: pprint-slot-value ( name value -- )
<flow \ { pprint-word
[ text ] [ f <inset pprint* block> ] bi*
\ } pprint-word block> ;
+: (pprint-tuple) ( opener class slots closer -- )
+ <flow {
+ [ pprint-word ]
+ [ pprint-word ]
+ [ t <inset [ pprint-slot-value ] assoc-each block> ]
+ [ pprint-word ]
+ } spread block> ;
+
+: ?pprint-tuple ( tuple quot -- )
+ [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
+
: pprint-tuple ( tuple -- )
- boa-tuples? get [ pprint-object ] [
- [
- <flow
- \ T{ pprint-word
- dup class pprint-word
- t <inset
- tuple>assoc [ pprint-slot-value ] assoc-each
- block>
- \ } pprint-word
- block>
- ] check-recursion
- ] if ;
+ [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
M: tuple pprint*
pprint-tuple ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
-M: curry >pprint-sequence ;
-M: compose >pprint-sequence ;
+M: callable >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
-M: tuple >pprint-sequence
- [ class ] [ tuple-slots ] bi
+: class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
+M: tuple >pprint-sequence
+ [ class ] [ tuple-slots ] bi class-slot-sequence ;
+
M: object pprint-narrow? drop f ;
M: byte-vector pprint-narrow? drop f ;
M: array pprint-narrow? drop t ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1+ cut [ (remove-breakpoints) ] bi@
+ 1 + cut [ (remove-breakpoints) ] bi@
[ -> ] glue
] [
drop
] each
] with-row
] each
- ] tabular-output nl ;
\ No newline at end of file
+ ] tabular-output nl ;
line-limit? [
"..." write pprinter get return
] when
- pprinter get [ 1+ ] change-line-count drop
+ pprinter get [ 1 + ] change-line-count drop
nl do-indent
] if ;
TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ \ text new-section
+ over length 1 + \ text new-section
swap >>style
swap >>string ;
: group-flow ( seq -- newseq )
[
dup length [
- 2dup 1- swap ?nth prev set
- 2dup 1+ swap ?nth next set
+ 2dup 1 - swap ?nth prev set
+ 2dup 1 + swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split harvest ;
: take-some ( seqs -- seqs seq )
0 over [ length + dup 76 >= ] find drop nip
- [ 1- cut-slice swap ] [ f swap ] if* concat ;
+ [ 1 - cut-slice swap ] [ f swap ] if* concat ;
: divide-lines ( strings -- strings )
[ dup ] [ take-some ] produce nip ;
(>>i) ;
M: random-dummy random-32* ( obj -- r )
- [ dup 1+ ] change-i drop ;
+ [ dup 1 + ] change-i drop ;
: y ( n seq -- y )
[ nth-unsafe 31 mask-bit ]
- [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
+ [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
: mt[k] ( offset n seq -- )
[
[
seq>>
[ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
- [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
- dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+ dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline
: init-mt-rest ( seq -- )
- n 1- swap '[
- _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
+ n 1 - swap '[
+ _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
[ seq>> nth-unsafe mt-temper ]
- [ [ 1+ ] change-i drop ] tri ;
+ [ [ 1 + ] change-i drop ] tri ;
[
[ 32 random-bits ] with-system-random
<PRIVATE
: random-integer ( n -- n' )
- dup log2 7 + 8 /i 1+
+ dup log2 7 + 8 /i 1 +
[ random-bytes >byte-array byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
- [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
+ [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
: delete-random ( seq -- elt )
: to-times ( term n -- ast )
dup zero?
[ 2drop epsilon ]
- [ dupd 1- to-times 2array <concatenation> <maybe> ]
+ [ dupd 1 - to-times 2array <concatenation> <maybe> ]
if ;
M: from-to <times>
drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
M: ^ question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
M: $unix question>quot
drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
M: ^unix question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth CHAR: \n = ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
M: word-break question>quot
drop [ word-break-at? ] ;
M: lookbehind question>quot ! Returns ( index string -- ? )
term>> <reversed-option>
ast>dfa dfa>reverse-shortest-word
- '[ [ 1- ] dip f _ execute ] ;
+ '[ [ 1 - ] dip f _ execute ] ;
: check-string ( string -- string )
! Make this configurable
GENERIC: end/start ( string regexp -- end start )
M: regexp end/start drop length 0 ;
-M: reverse-regexp end/start drop length 1- -1 swap ;
+M: reverse-regexp end/start drop length 1 - -1 swap ;
PRIVATE>
:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
i string regexp quot call dup [| j |
j i j
- reverse? [ swap [ 1+ ] bi@ ] when
+ reverse? [ swap [ 1 + ] bi@ ] when
string
] [ drop f f f f ] if ; inline
: search-range ( i string reverse? -- seq )
- [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline
+ [ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
f f f f
[ subseq ] map-matches ;
: count-matches ( string regexp -- n )
- [ 0 ] 2dip [ 3drop 1+ ] each-match ;
+ [ 0 ] 2dip [ 3drop 1 + ] each-match ;
<PRIVATE
dup skip-blank [
[ index-from ] 2keep
[ swapd subseq ]
- [ 2drop 1+ ] 3bi
+ [ 2drop 1 + ] 3bi
] change-lexer-column ;
: parse-noblank-token ( lexer -- str/f )
"prettyprint" vocab [
"regexp.prettyprint" require
-] when
\ No newline at end of file
+] when
M: word declarations.
{
POSTPONE: delimiter
+ POSTPONE: deprecated
POSTPONE: inline
POSTPONE: recursive
POSTPONE: foldable
] { } make prune ;
: see-methods ( word -- )
- methods see-all nl ;
\ No newline at end of file
+ methods see-all nl ;
M: complex-sequence length
seq>> length -1 shift ;
M: complex-sequence nth-unsafe
- complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ;
+ complex@ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi rect> ;
M: complex-sequence set-nth-unsafe
complex@
[ [ real-part ] [ ] [ ] tri* set-nth-unsafe ]
- [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ;
+ [ [ imaginary-part ] [ 1 + ] [ ] tri* set-nth-unsafe ] 3bi ;
! The last case is needed because a very large number would
! otherwise be confused with a small number.
: serialize-cell ( n -- )
- dup zero? [ drop 0 write1 ] [
+ [ 0 write1 ] [
dup HEX: 7e <= [
HEX: 80 bitor write1
] [
- dup log2 8 /i 1+
+ dup log2 8 /i 1 +
dup HEX: 7f >= [
HEX: ff write1
dup serialize-cell
] if
>be write
] if
- ] if ;
+ ] if-zero ;
: deserialize-cell ( -- n )
read1 {
drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup zero? [
- drop CHAR: z write1
+ [
+ CHAR: z write1
] [
dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
serialize-cell
- ] if ;
+ ] if-zero ;
M: float (serialize) ( obj -- )
CHAR: F write1
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
- binary [ serialize ] with-byte-writer ;
\ No newline at end of file
+ binary [ serialize ] with-byte-writer ;
WHERE
-: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
;FUNCTOR
<PRIVATE
:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
+ n n 1 - [ seq nth quot call ] bi@ >= [
+ n n 1 - seq exchange
+ seq quot n 1 - insert
] unless
] unless ; inline recursive
PRIVATE>
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
-specialized-arrays ;
+specialized-arrays prettyprint.custom ;
IN: specialized-arrays.direct.functor
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
>A' IS >${T}-array
<A'> IS <${A'}>
+A'{ IS ${A'}{
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
M: A like drop dup A instance? [ >A' ] unless ;
M: A new-sequence drop <A'> ;
+M: A pprint-delims drop \ A'{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
INSTANCE: A sequence
;FUNCTOR
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
swap A boa ; inline
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
+M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
-M: A length length>> ;
+M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ;
+M: A nth-unsafe underlying>> NTH call ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ;
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-: >A ( seq -- specialized-array ) A new clone-like ; inline
+: >A ( seq -- specialized-array ) A new clone-like ;
-M: A like drop dup A instance? [ >A ] unless ;
+M: A like drop dup A instance? [ >A ] unless ; inline
-M: A new-sequence drop (A) ;
+M: A new-sequence drop (A) ; inline
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
[ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
] 2bi
- A boa ;
+ A boa ; inline
-M: A byte-length underlying>> length ;
+M: A byte-length underlying>> length ; inline
M: A pprint-delims drop \ A{ \ } ;
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
- dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+ dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
swap
] dip
- '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
+ '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline
PRIVATE>
continuations assocs combinators compiler.errors accessors math.order
definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state ;
+stack-checker.recursive-state summary ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
-: bad-call ( -- )
- "call must be given a callable" time-bomb ;
+ERROR: bad-call obj ;
+
+M: bad-call summary
+ drop "call must be given a callable" ;
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
[ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
- drop bad-call
+ value>> \ bad-call boa time-bomb
] if
] if ;
\ compose [ infer-compose ] "special" set-word-prop
+ERROR: bad-executable obj ;
+
+M: bad-executable summary
+ drop "execute must be given a word" ;
+
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
- drop
- "execute must be given a word" time-bomb
+ \ bad-executable boa time-bomb
] if ;
\ execute [ infer-execute ] "special" set-word-prop
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1+ { tuple } <effect>
+ peek-d literal value>> second 1 + { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+\ <tuple-boa> t "flushable" set-word-prop
+
: infer-effect-unsafe ( word -- )
pop-literal nip
add-effect-input
: from-to ( index begin suffix-array -- from/f to/f )
swap '[ _ head? not ]
- [ find-last-from drop dup [ 1+ ] when ]
+ [ find-last-from drop dup [ 1 + ] when ]
[ find-from drop ] 3bi ;
: <funky-slice> ( from/f to/f seq -- slice )
! erg's bug
GENERIC: some-generic ( a -- b )
-M: integer some-generic 1+ ;
+M: integer some-generic 1 + ;
[ 4 ] [ 3 some-generic ] unit-test
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1 - ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
: some-code ( -- )
f my-generic drop ;
-[ ] [ some-code ] unit-test
\ No newline at end of file
+[ ] [ some-code ] unit-test
:: (fuzzy) ( accum i full ch -- accum i full ? )
ch i full index-from [
:> i i accum push
- accum i 1+ full t
+ accum i 1 + full t
] [
f -1 full f
] if* ;
[
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
- 1+
+ 1 +
] keep pick last push
] each ;
: score-1 ( i full -- n )
{
{ [ over zero? ] [ 2drop 10 ] }
- { [ 2dup length 1- number= ] [ 2drop 4 ] }
- { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
- { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
+ { [ 2dup length 1 - number= ] [ 2drop 4 ] }
+ { [ 2dup [ 1 - ] dip nth Letter? not ] [ 2drop 10 ] }
+ { [ 2dup [ 1 + ] dip nth Letter? not ] [ 2drop 4 ] }
[ 2drop 1 ]
} cond ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax kernel words ;
+IN: tools.deprecation
+
+HELP: :deprecations
+{ $description "Prints all deprecation notes." } ;
+
+ARTICLE: "tools.deprecation" "Deprecation tracking"
+"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words."
+{ $subsection POSTPONE: deprecated }
+{ $subsection :deprecations } ;
+
+ABOUT: "tools.deprecation"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs compiler.units
+debugger init io kernel namespaces prettyprint sequences
+source-files.errors summary tools.crossref
+tools.crossref.private tools.errors words ;
+IN: tools.deprecation
+
+SYMBOL: +deprecation-note+
+SYMBOL: deprecation-notes
+
+deprecation-notes [ H{ } clone ] initialize
+
+TUPLE: deprecation-note < source-file-error ;
+
+M: deprecation-note error-type drop +deprecation-note+ ;
+
+TUPLE: deprecated-usages asset usages ;
+
+: :deprecations ( -- )
+ deprecation-notes get-global values errors. ;
+
+T{ error-type
+ { type +deprecation-note+ }
+ { word ":deprecations" }
+ { plural "deprecated word usages" }
+ { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
+ { quot [ deprecation-notes get values ] }
+ { forget-quot [ deprecation-notes get delete-at ] }
+} define-error-type
+
+: <deprecation-note> ( error word -- deprecation-note )
+ \ deprecation-note <definition-error> ;
+
+: deprecation-note ( word usages -- )
+ [ deprecated-usages boa ]
+ [ drop <deprecation-note> ]
+ [ drop deprecation-notes get-global set-at ] 2tri ;
+
+: clear-deprecation-note ( word -- )
+ deprecation-notes get-global delete-at ;
+
+: check-deprecations ( word -- )
+ dup "forgotten" word-prop
+ [ clear-deprecation-note ] [
+ dup def>> uses [ deprecated? ] filter
+ [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
+ ] if ;
+
+M: deprecated-usages summary
+ drop "Deprecated words used" ;
+
+M: deprecated-usages error.
+ "The definition of " write
+ dup asset>> pprint
+ " uses these deprecated words:" write nl
+ usages>> [ " " write pprint nl ] each ;
+
+SINGLETON: deprecation-observer
+
+: initialize-deprecation-notes ( -- )
+ get-crossref [ drop deprecated? ] assoc-filter
+ values [ keys [ check-deprecations ] each ] each ;
+
+M: deprecation-observer definitions-changed
+ drop keys [ word? ] filter
+ dup [ deprecated? ] filter empty?
+ [ [ check-deprecations ] each ]
+ [ drop initialize-deprecation-notes ] if ;
+
+[ \ deprecation-observer add-definition-observer ]
+"tools.deprecation" add-init-hook
+
+initialize-deprecation-notes
--- /dev/null
+Tracking usage of deprecated words
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline
-M: CLASS-array length length>> ;
+M: CLASS-array length length>> ; inline
-M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
+M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
-M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
+M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
-M: CLASS-array new-sequence drop <CLASS-array> ;
+M: CLASS-array new-sequence drop <CLASS-array> ; inline
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
-M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
+M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
INSTANCE: CLASS-array sequence
lf>crlf [
utf16n string>alien
EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
+ GMEM_MOVEABLE over length 1 + GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
<PRIVATE
-: page-elt ( editor -- editor element ) dup visible-lines 1- <page-elt> ;
+: page-elt ( editor -- editor element ) dup visible-lines 1
- <page-elt> ;
PRIVATE>
: this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ]
- [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ]
+ [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ]
2bi ;
: last-line? ( document line -- ? )
[ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
: available-space ( pref-dim gap dims -- avail )
- length 1+ * [-] ; inline
+ length 1 + * [-] ; inline
: -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
[ <frame-grid> ] dip new-grid ; inline
: <frame> ( cols rows -- frame )
- frame new-frame ;
\ No newline at end of file
+ frame new-frame ;
mock-gadget new 0 >>graft-called 0 >>ungraft-called ;
M: mock-gadget graft*
- [ 1+ ] change-graft-called drop ;
+ [ 1 + ] change-graft-called drop ;
M: mock-gadget ungraft*
- [ 1+ ] change-ungraft-called drop ;
+ [ 1 + ] change-ungraft-called drop ;
! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
3 [
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
- swap 1+ number>string set
+ swap 1 + number>string set
] each ;
: status-flags ( -- seq )
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
: line>y ( n gadget -- y ) line-height * >integer ;
: validate-line ( m gadget -- n )
- control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+ control-value [ drop f ] [ length 1 - min 0 max ] if-empty ;
: valid-line? ( n gadget -- ? )
- control-value length 1- 0 swap between? ;
+ control-value length 1 - 0 swap between? ;
: visible-line ( gadget quot -- n )
'[
[ loc>> ] visible-line ;
: last-visible-line ( gadget -- n )
- [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ;
+ [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ;
: each-slice-index ( from to seq quot -- )
[ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
2bi 2array ;
: visible-lines ( gadget -- n )
- [ visible-dim second ] [ line-height ] bi /i ;
\ No newline at end of file
+ [ visible-dim second ] [ line-height ] bi /i ;
0 select-row ;
: last-row ( table -- )
- dup control-value length 1- select-row ;
+ dup control-value length 1 - select-row ;
: prev/next-page ( table n -- )
- over visible-lines 1- * prev/next-row ;
+ over visible-lines 1 - * prev/next-row ;
: previous-page ( table -- )
-1 prev/next-page ;
dup renderer>> column-titles
[ <column-headers> ] [ drop f ] if ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
- colors length dup 1- v/n [ v*n ] with map
+ colors length dup 1 - v/n [ v*n ] with map
swap [ over v+ 2array ] curry map
concat concat >float-array ;
[ colors>> draw-gradient ]
} cleave ;
-M: gradient pen-background 2drop transparent ;
\ No newline at end of file
+M: gradient pen-background 2drop transparent ;
\r
M: uniscribe-renderer x>offset ( x font string -- n )\r
[ 2drop 0 ] [\r
- cached-script-string x>line-offset 0 = [ 1+ ] unless\r
+ cached-script-string x>line-offset 0 = [ 1 + ] unless\r
] if-empty ;\r
\r
M: uniscribe-renderer offset>x ( n font string -- x )\r
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
{ { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
{ { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
+ { { $image "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } "Deprecated words used" { $link "tools.deprecation" } }
} ;
ABOUT: "ui.tools.error-list"
{ 5 5 } >>gap
error-list <error-list-toolbar> f track-add
error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
- error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
- error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+ error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/4 track-add
+ error-list error-display>> "Details" <labeled-gadget> 1/2 track-add
{ 5 5 } <filled-border> 1 track-add ;
M: error-list-gadget focusable-child*
V{ } clone 0 history boa ;
: history-add ( history -- input )
- dup elements>> length 1+ >>index
+ dup elements>> length 1 + >>index
[ document>> doc-string [ <input> ] [ empty? ] bi ] keep
'[ [ _ elements>> push ] keep ] unless ;
[ set-doc-string ] [ clear-undo drop ] 2bi ;
: change-history-index ( history i -- )
- over elements>> length 1-
+ over elements>> length 1 -
'[ _ + _ min 0 max ] change-index drop ;
: history-recall ( history i -- )
M: interactor dispose drop ;
: go-to-error ( interactor error -- )
- [ line>> 1- ] [ column>> ] bi 2array
+ [ line>> 1 - ] [ column>> ] bi 2array
over set-caret
mark>caret ;
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
+ [ com-end ] [ call-next-method ] bi ;
] [
[
[ traverse-step traverse-from-path ]
- [ tuck children>> swap first 1+ tail-slice % ] 2bi
+ [ tuck children>> swap first 1 + tail-slice % ] 2bi
] make-node
] if
] if ;
traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
- [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
+ [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- )
traverse-step traverse-to-path ;
M: gadget leaves* conjoin ;
-: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
#! etc.
swap 2array windows get-global push
windows get-global dup length 1 >
- [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+ [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
windows [ [ first = not ] with filter ] change-global ;
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: first-grapheme-from ( start str -- i )
over tail-slice first-grapheme + ;
swap [ format/extended? not ] find-from drop ;
: walk-up ( str i -- j )
- dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
+ dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ;
: (walk-down) ( str i -- j )
swap [ format/extended? not ] find-last-from drop ;
: walk-down ( str i -- j )
- dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
+ dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ;
: word-break? ( str i table-entry -- ? )
{
: first-word ( str -- i )
[ unclip-slice word-break-prop over <enum> ] keep
'[ swap _ word-break-next ] assoc-find 2drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: >words ( str -- words )
[ first-word ] >pieces ;
<PRIVATE
: nth-next ( i str -- str[i-1] str[i] )
- [ [ 1- ] keep ] dip '[ _ nth ] bi@ ;
+ [ [ 1 - ] keep ] dip '[ _ nth ] bi@ ;
PRIVATE>
:: assert= ( test spec quot -- )
spec [
[
- [ 1- test nth ] bi@
+ [ 1 - test nth ] bi@
[ 1quotation ] [ quot curry ] bi* unit-test
] with each
] assoc-each ;
! Normalization -- Composition
: initial-medial? ( str i -- ? )
- { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
+ { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ;
: --final? ( str i -- ? )
2 + swap ?nth final? ;
: compose-jamo ( str i -- str i )
2dup initial-medial? [
2dup --final? [ imf, ] [ im, ] if
- ] [ 2dup swap nth , 1+ ] if ;
+ ] [ 2dup swap nth , 1 + ] if ;
: pass-combining ( str -- str i )
dup [ non-starter? not ] find drop
: get-str ( state i -- ch )
swap [ i>> + ] [ str>> ] bi ?nth ; inline
: current ( state -- ch ) 0 get-str ; inline
-: to ( state -- state ) [ 1+ ] change-i ; inline
+: to ( state -- state ) [ 1 + ] change-i ; inline
: push-after ( ch state -- state ) [ ?push ] change-after ; inline
:: try-compose ( state new-char current-class -- state )
:: (compose) ( str i -- )
i str ?nth [
dup jamo? [ drop str i compose-jamo ] [
- i 1+ str ?nth combining-class
- [ str i 1+ compose-combining ] [ , str i 1+ ] if
+ i 1 + str ?nth combining-class
+ [ str i 1 + compose-combining ] [ , str i 1 + ] if
] if (compose)
] when* ; inline recursive
#! first group is -1337, legacy unix code
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ getgrouplist io-error ] 2keep
- [ 4 tail-slice ] [ *int 1- ] bi* >groups ;
+ [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
HEX: ff00 bitand -8 shift ; inline
: WIFSIGNALED ( status -- ? )
- HEX: 7f bitand 1+ -1 shift 0 > ; inline
+ HEX: 7f bitand 1 + -1 shift 0 > ; inline
: WCOREFLAG ( -- value )
HEX: 80 ; inline
: <front-node> ( elt front -- node )
[
unroll-factor 0 <array>
- [ unroll-factor 1- swap set-nth ] keep f
+ [ unroll-factor 1 - swap set-nth ] keep f
] dip [ node boa dup ] keep
dup [ (>>prev) ] [ 2drop ] if ; inline
] [ dup front>> >>back ] if* drop ; inline
: push-front/new ( elt list -- )
- unroll-factor 1- >>front-pos
+ unroll-factor 1 - >>front-pos
[ <front-node> ] change-front
normalize-back ; inline
: push-front/existing ( elt list front -- )
- [ [ 1- ] change-front-pos ] dip
+ [ [ 1 - ] change-front-pos ] dip
[ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-front*
: pop-front/existing ( list front -- )
[ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
- [ 1+ ] change-front-pos
+ [ 1 + ] change-front-pos
drop ; inline
M: unrolled-list pop-front*
dup front>> [ empty-unrolled-list ] unless*
- over front-pos>> unroll-factor 1- eq?
+ over front-pos>> unroll-factor 1 - eq?
[ pop-front/new ] [ pop-front/existing ] if ;
: <back-node> ( elt back -- node )
normalize-front ; inline
: push-back/existing ( elt list back -- )
- [ [ 1+ ] change-back-pos ] dip
- [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
+ [ [ 1 + ] change-back-pos ] dip
+ [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-back*
dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
M: unrolled-list peek-back
dup back>>
- [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
+ [ [ back-pos>> 1 - ] dip data>> nth-unsafe ]
[ empty-unrolled-list ]
if* ;
dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
: pop-back/existing ( list back -- )
- [ [ 1- ] change-back-pos ] dip
+ [ [ 1 - ] change-back-pos ] dip
[ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
drop ; inline
2dup length 2 - >= [
2drop
] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ [ 1 + dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup nth dup CHAR: % = [
drop url-decode-% [ 3 + ] dip
] [
- , [ 1+ ] dip
+ , [ 1 + ] dip
] if url-decode-iter
] if ;
[ f ] [ foo ] unit-test\r
[ ] [ 3 to: foo ] unit-test\r
[ 3 ] [ foo ] unit-test\r
-[ ] [ \ foo [ 1+ ] change-value ] unit-test\r
+[ ] [ \ foo [ 1 + ] change-value ] unit-test\r
[ 4 ] [ foo ] unit-test\r
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
- ] unless ;
+ ] unless ; inline
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
-M: A new-resizable drop <V> ;
+M: A new-resizable drop <V> ; inline
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
M: vlist ppush
>vlist<
2dup length = [ unshare ] unless
- [ [ 1+ swap ] dip push ] keep vlist boa ;
+ [ [ 1 + swap ] dip push ] keep vlist boa ;
ERROR: empty-vlist-error ;
M: vlist ppop
[ empty-vlist-error ]
- [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+ [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ;
M: vlist clone
[ length>> ] [ vector>> >vector ] bi vlist boa ;
: valist-at ( key i array -- value ? )
over 0 >= [
3dup nth-unsafe = [
- [ 1+ ] dip nth-unsafe nip t
+ [ 1 + ] dip nth-unsafe nip t
] [
[ 2 - ] dip valist-at
] if
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
- +vtbl-counter+ [ 1+ dup ] change ;
+ +vtbl-counter+ [ 1 + dup ] change ;
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
_
- [ alien-unsigned-4 1+ dup ]
+ [ alien-unsigned-4 1 + dup ]
[ set-alien-unsigned-4 ]
2bi
] ;
length "void*" heap-size * '[
_
[ drop ]
- [ alien-unsigned-4 1- dup ]
+ [ alien-unsigned-4 1 - dup ]
[ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
+ [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
- 2dup f 0 DragQueryFile 1+ ! get size of filename buffer\r
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
dup "WCHAR" <c-array>\r
[ swap DragQueryFile drop ] keep\r
alien>u16-string\r
GetLastError n>win32-error-string ;
: (win32-error) ( n -- )
- dup zero? [
- drop
- ] [
- win32-error-string throw
- ] if ;
+ [ win32-error-string throw ] unless-zero ;
: win32-error ( -- )
GetLastError (win32-error) ;
USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types debugger io
+kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32
combinators locals specialized-arrays.direct.uchar ;
IN: windows.ole32
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
-TUPLE: ole32-error error-code ;
-C: <ole32-error> ole32-error
+TUPLE: ole32-error code message ;
-M: ole32-error error.
- "COM method failed: " print error-code>> n>win32-error-string print ;
+: <ole32-error> ( code -- error )
+ dup n>win32-error-string \ ole32-error boa ;
: ole32-error ( hresult -- )
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
: line-offset>x ( n script-string -- x )
2dup string>> length = [
ssa>> ! ssa
- swap 1- ! icp
+ swap 1 - ! icp
TRUE ! fTrailing
] [
ssa>>
: number<-> ( doc -- dup )
0 over [
dup var>> [
- over >>var [ 1+ ] dip
+ over >>var [ 1 + ] dip
] unless drop
] each-interpolated drop ;
swap
[ version-1.0?>> over text? not ]
[ check>> ] bi and [
- spot get [ 1+ ] change-column drop
+ spot get [ 1 + ] change-column drop
disallowed-char
] [ drop ] if
] [ drop ] if* ;
: record ( spot char -- spot )
over char>> [
CHAR: \n =
- [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if
+ [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if
>>column
] [ drop ] if ;
: take-string ( match -- string )
dup length <circular-string>
spot get '[ 2dup _ string-matches? ] take-until nip
- dup length rot length 1- - head
+ dup length rot length 1 - - head
get-char [ missing-close ] unless next ;
: expect ( string -- )
drop
seen-whitespace-end? get [
- position get 1+ whitespace-end set
+ position get 1 + whitespace-end set
] unless
(check-word-break)
: next-token, ( len id -- )
[ position get 2dup + ] dip token,
- position get + dup 1- position set last-offset set ;
+ position get + dup 1 - position set last-offset set ;
: push-context ( rules -- )
context [ <line-context> ] change ;
}
refresh_image() {
- ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit"
+ ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit"
check_ret factor
}
make_boot_image() {
- ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit"
+ ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USING: system bootstrap.image memory ; make-image save 0 exit"
check_ret factor
}
GENERIC: >c-ptr ( obj -- c-ptr )
-M: c-ptr >c-ptr ;
+M: c-ptr >c-ptr ; inline
SLOT: underlying
-M: object >c-ptr underlying>> ;
+M: object >c-ptr underlying>> ; inline
GENERIC: expired? ( c-ptr -- ? ) flushable
sequences sequences.private ;
IN: arrays
-M: array clone (clone) ;
-M: array length length>> ;
-M: array nth-unsafe [ >fixnum ] dip array-nth ;
-M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
-M: array resize resize-array ;
+M: array clone (clone) ; inline
+M: array length length>> ; inline
+M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
+M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
+M: array resize resize-array ; inline
: >array ( seq -- array ) { } clone-like ;
-M: object new-sequence drop 0 <array> ;
+M: object new-sequence drop 0 <array> ; inline
-M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] if ;
+M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
-IN: assocs.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations specialized-arrays.double ;
+IN: assocs.tests
[ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
H{ { 1 3 } { 2 5 } }
H{ { 1 7 } { 5 6 } }
} assoc-refine
-] unit-test
\ No newline at end of file
+] unit-test
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
-M: assoc assoc-like drop ;
+M: assoc assoc-like drop ; inline
: ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
- [ [ set-at ] with-assoc assoc-each ] keep ;
+ [ [ set-at ] with-assoc assoc-each ] keep ; inline
: keys ( assoc -- keys )
[ drop ] { } assoc>map ;
[ 2nip set-second ]
[ drop [ swap 2array ] dip push ] if ;
-M: sequence new-assoc drop <vector> ;
+M: sequence new-assoc drop <vector> ; inline
-M: sequence clear-assoc delete-all ;
+M: sequence clear-assoc delete-all ; inline
M: sequence delete-at
[ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ;
-M: sequence assoc-size length ;
+M: sequence assoc-size length ; inline
M: sequence assoc-clone-like
- [ >alist ] dip clone-like ;
+ [ >alist ] dip clone-like ; inline
M: sequence assoc-like
- [ >alist ] dip like ;
+ [ >alist ] dip like ; inline
-M: sequence >alist ;
+M: sequence >alist ; inline
! Override sequence => assoc instance for f
-M: f clear-assoc drop ;
+M: f clear-assoc drop ; inline
-M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
+M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
INSTANCE: sequence assoc
-TUPLE: enum seq ;
+TUPLE: enum { seq read-only } ;
C: <enum> enum
M: enum at*
seq>> 2dup bounds-check?
- [ nth t ] [ 2drop f f ] if ;
+ [ nth t ] [ 2drop f f ] if ; inline
-M: enum set-at seq>> set-nth ;
+M: enum set-at seq>> set-nth ; inline
-M: enum delete-at seq>> delete-nth ;
+M: enum delete-at seq>> delete-nth ; inline
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep zip ;
+ seq>> [ length ] keep zip ; inline
-M: enum assoc-size seq>> length ;
+M: enum assoc-size seq>> length ; inline
-M: enum clear-assoc seq>> delete-all ;
+M: enum clear-assoc seq>> delete-all ; inline
INSTANCE: enum assoc
"M\\"
"]"
"delimiter"
+ "deprecated"
"f"
"flushable"
"foldable"
+USING: tools.test byte-arrays sequences kernel math ;\r
IN: byte-arrays.tests\r
-USING: tools.test byte-arrays sequences kernel ;\r
\r
[ 6 B{ 1 2 3 } ] [\r
6 B{ 1 2 3 } resize-byte-array\r
\r
[ -10 B{ } resize-byte-array ] must-fail\r
\r
-[ B{ 123 } ] [ 123 1byte-array ] unit-test
\ No newline at end of file
+[ B{ 123 } ] [ 123 1byte-array ] unit-test\r
+\r
+[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test\r
+\r
+[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test
\ No newline at end of file
sequences.private math ;
IN: byte-arrays
-M: byte-array clone (clone) ;
-M: byte-array length length>> ;
-M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
-M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
+M: byte-array clone (clone) ; inline
+M: byte-array length length>> ; inline
+M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline
+M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array new-sequence drop (byte-array) ;
+M: byte-array new-sequence drop (byte-array) ; inline
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
M: byte-array resize
- resize-byte-array ;
+ resize-byte-array ; inline
INSTANCE: byte-array sequence
-IN: byte-vectors.tests\r
USING: tools.test byte-vectors vectors sequences kernel\r
prettyprint ;\r
+IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
drop dup byte-vector? [\r
dup byte-array?\r
[ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline\r
\r
M: byte-vector equal?\r
over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
\r
-M: byte-vector contract 2drop ;\r
+M: byte-vector contract 2drop ; inline\r
\r
M: byte-array like\r
#! If we have an byte-array, we're done.\r
2dup length eq?\r
[ nip ] [ resize-byte-array ] if\r
] [ >byte-array ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
-M: byte-array new-resizable drop <byte-vector> ;\r
+M: byte-array new-resizable drop <byte-vector> ; inline\r
\r
INSTANCE: byte-vector growable\r
+++ /dev/null
-IN: checksums.tests
-USING: checksums tools.test ;
-
: class= ( first second -- ? )\r
[ class<= ] [ swap class<= ] 2bi and ;\r
\r
+ERROR: topological-sort-failed ;\r
+\r
: largest-class ( seq -- n elt )\r
dup [ [ class< ] with any? not ] curry find-last\r
- [ "Topological sort failed" throw ] unless* ;\r
+ [ topological-sort-failed ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
[ name>> ] sort-with >vector\r
-IN: classes.builtin.tests
USING: tools.test words sequences kernel memory accessors ;
+IN: classes.builtin.tests
[ f ] [
[ word? ] instances
: bootstrap-type>class ( n -- class ) builtins get nth ;
-M: hi-tag class hi-tag type>class ;
+M: hi-tag class hi-tag type>class ; inline
-M: object class tag type>class ;
+M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
"class-intersect-no-method-c" parse-stream drop
] unit-test
+! Forget the above crap
+[
+ { "classes.test.a" "classes.test.b" "classes.test.c" "classes.test.d" }
+ [ forget-vocab ] each
+] with-compilation-unit
+
TUPLE: forgotten-predicate-test ;
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
-IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple eval multiline ;
+IN: classes.tuple.parser.tests
TUPLE: test-1 ;
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
\ No newline at end of file
+] [ error>> unexpected-eof? ] must-fail-with
: parse-slot-values ( -- values )
[ (parse-slot-values) ] { } make ;
-: boa>tuple ( class slots -- tuple )
+GENERIC# boa>object 1 ( class slots -- tuple )
+
+M: tuple-class boa>object
swap prefix >tuple ;
-: assoc>tuple ( class slots -- tuple )
- [ [ ] [ initial-values ] [ all-slots ] tri ] dip
- swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
- [ dup <enum> ] dip update boa>tuple ;
+: assoc>object ( class slots values -- tuple )
+ [ [ [ initial>> ] map ] keep ] dip
+ swap [ [ slot-named* drop ] curry dip ] curry assoc-map
+ [ dup <enum> ] dip update boa>object ;
-: parse-tuple-literal-slots ( class -- tuple )
+: parse-tuple-literal-slots ( class slots -- tuple )
scan {
{ f [ unexpected-eof ] }
- { "f" [ \ } parse-until boa>tuple ] }
- { "{" [ parse-slot-values assoc>tuple ] }
- { "}" [ new ] }
+ { "f" [ drop \ } parse-until boa>object ] }
+ { "{" [ parse-slot-values assoc>object ] }
+ { "}" [ drop new ] }
[ bad-literal-tuple ]
} case ;
: parse-tuple-literal ( -- tuple )
- scan-word parse-tuple-literal-slots ;
+ scan-word dup all-slots parse-tuple-literal-slots ;
: layout-of ( tuple -- layout )
1 slot { array } declare ; inline
-M: tuple class layout-of 2 slot { word } declare ;
+M: tuple class layout-of 2 slot { word } declare ; inline
: tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline
[ swap classes-intersect? ]
} cond ;
-M: tuple clone (clone) ;
+M: tuple clone (clone) ; inline
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
-IN: effects.tests
USING: effects tools.test prettyprint accessors sequences ;
+IN: effects.tests
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
-[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] produce nip ;
+ERROR: stack-effect-omits-dashes effect ;
+
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
+ [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
: complete-effect ( -- effect )
"(" expect ")" parse-effect ;
-IN: generic.math.tests
USING: generic.math math tools.test kernel ;
+IN: generic.math.tests
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
-IN: generic.single.tests
USING: tools.test math math.functions math.constants generic.standard
generic.single strings sequences arrays kernel accessors words
specialized-arrays.double byte-arrays bit-arrays parser namespaces
make quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors.double
definitions generic sets graphs assocs grouping see eval ;
+IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
! Corner case
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
-must-fail-with
\ No newline at end of file
+must-fail-with
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
+ERROR: unreachable ;
+
: prune-redundant-predicates ( assoc -- default assoc' )
{
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup empty? ] [ drop [ unreachable ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
SLOT: length
SLOT: underlying
-M: growable length length>> ;
-M: growable nth-unsafe underlying>> nth-unsafe ;
-M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
+M: growable length length>> ; inline
+M: growable nth-unsafe underlying>> nth-unsafe ; inline
+M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
: capacity ( seq -- n ) underlying>> length ; inline
[ >fixnum ] dip
] if ; inline
-M: growable set-nth ensure set-nth-unsafe ;
+M: growable set-nth ensure set-nth-unsafe ; inline
-M: growable clone (clone) [ clone ] change-underlying ;
+M: growable clone (clone) [ clone ] change-underlying ; inline
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
2dup (>>length)
- ] when 2drop ;
+ ] when 2drop ; inline
M: growable shorten ( n seq -- )
growable-check
2dup length < [
2dup contract
2dup (>>length)
- ] when 2drop ;
+ ] when 2drop ; inline
INSTANCE: growable sequence
-IN: hashtables.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
+IN: hashtables.tests
[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
\ No newline at end of file
+[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
] if ;
M: hashtable assoc-size ( hash -- n )
- [ count>> ] [ deleted>> ] bi - ;
+ [ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- )
dup >alist [
] keep { } like ;
M: hashtable clone
- (clone) [ clone ] change-array ;
+ (clone) [ clone ] change-array ; inline
M: hashtable equal?
over hashtable? [
] [ 2drop f ] if ;
! Default method
-M: assoc new-assoc drop <hashtable> ;
+M: assoc new-assoc drop <hashtable> ; inline
-M: f new-assoc drop <hashtable> ;
+M: f new-assoc drop <hashtable> ; inline
: >hashtable ( assoc -- hashtable )
H{ } assoc-clone-like ;
M: hashtable assoc-like
- drop dup hashtable? [ >hashtable ] unless ;
+ drop dup hashtable? [ >hashtable ] unless ; inline
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
-IN: io.backend.tests
USING: tools.test io.backend kernel ;
+IN: io.backend.tests
[ ] [ "a" normalize-path drop ] unit-test
dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char
- drop decode-utf8 ;
+ drop decode-utf8 ; inline
! Encoding UTF-8
PRIVATE>
: code-point-length ( n -- x )
- dup zero? [ drop 1 ] [
+ [ 1 ] [
log2 {
{ [ dup 0 6 between? ] [ 1 ] }
{ [ dup 7 10 between? ] [ 2 ] }
{ [ dup 11 15 between? ] [ 3 ] }
{ [ dup 16 20 between? ] [ 4 ] }
} cond nip
- ] if ;
+ ] if-zero ;
: code-point-offsets ( string -- indices )
0 [ code-point-length + ] accumulate swap suffix ;
USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings namespaces ;
+io.encodings.utf8 io kernel arrays strings namespaces math ;
[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
read1
] with-byte-reader
] unit-test
+
+! Overly aggressive compiler optimizations
+[ B{ 123 } ] [
+ binary [ 123 >bignum write1 ] with-byte-writer
+] unit-test
\ No newline at end of file
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
- [ [ 1+ ] change-index drop ] bi ;
+ [ [ 1 + ] change-index drop ] bi ;
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
-M: object hashcode* 2drop 0 ;
+M: object hashcode* 2drop 0 ; inline
-M: f hashcode* 2drop 31337 ;
+M: f hashcode* 2drop 31337 ; inline
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
-M: object equal? 2drop f ;
+M: object equal? 2drop f ; inline
TUPLE: identity-tuple ;
-M: identity-tuple equal? 2drop f ;
+M: identity-tuple equal? 2drop f ; inline
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [
GENERIC: clone ( obj -- cloned )
-M: object clone ;
+M: object clone ; inline
-M: callstack clone (clone) ;
+M: callstack clone (clone) ; inline
! Tuple construction
GENERIC: new ( class -- tuple )
-IN: system.tests\r
USING: layouts math tools.test ;\r
+IN: system.tests\r
\r
[ t ] [ cell integer? ] unit-test\r
[ t ] [ bootstrap-cell integer? ] unit-test\r
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
- [ >fixnum ] [ >bignum ] if ;
+ [ >fixnum ] [ >bignum ] if ; inline
UNION: immediate fixnum POSTPONE: f ;
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
- [ line>> ] [ text>> ] bi length <= ;
+ [ line>> ] [ text>> length ] bi <= ;
: still-parsing-line? ( lexer -- ? )
[ column>> ] [ line-length>> ] bi < ;
HELP: bits>double ( n -- x )
{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } }
-{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
+{ $description "Creates a " { $link float } " object from a 64-bit binary representation. This word is usually used to reconstruct floats read from streams." } ;
{ bits>double bits>float double>bits float>bits } related-words
HELP: bits>float ( n -- x )
{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } }
-{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
+{ $description "Creates a " { $link float } " object from a 32-bit binary representation. This word is usually used to reconstruct floats read from streams." } ;
HELP: double>bits ( x -- n )
{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } }
-{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
+{ $description "Creates a 64-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ;
HELP: float>bits ( x -- n )
{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } }
-{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
+{ $description "Creates a 32-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ;
! Unsafe primitives
HELP: float+ ( x y -- z )
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.private ;
IN: math.floats.private
-M: fixnum >float fixnum>float ;
-M: bignum >float bignum>float ;
+M: fixnum >float fixnum>float ; inline
+M: bignum >float bignum>float ; inline
-M: float >fixnum float>fixnum ;
-M: float >bignum float>bignum ;
-M: float >float ;
+M: float >fixnum float>fixnum ; inline
+M: float >bignum float>bignum ; inline
+M: float >float ; inline
-M: float hashcode* nip float>bits ;
-M: float equal? over float? [ float= ] [ 2drop f ] if ;
-M: float number= float= ;
+M: float hashcode* nip float>bits ; inline
+M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
+M: float number= float= ; inline
-M: float < float< ;
-M: float <= float<= ;
-M: float > float> ;
-M: float >= float>= ;
+M: float < float< ; inline
+M: float <= float<= ; inline
+M: float > float> ; inline
+M: float >= float>= ; inline
-M: float + float+ ;
-M: float - float- ;
-M: float * float* ;
-M: float / float/f ;
-M: float /f float/f ;
-M: float /i float/f >integer ;
-M: float mod float-mod ;
+M: float + float+ ; inline
+M: float - float- ; inline
+M: float * float* ; inline
+M: float / float/f ; inline
+M: float /f float/f ; inline
+M: float /i float/f >integer ; inline
+M: float mod float-mod ; inline
-M: real abs dup 0 < [ neg ] when ;
+M: real abs dup 0 < [ neg ] when ; inline
+
+M: float fp-special?
+ double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
+
+M: float fp-nan-payload
+ double>bits 52 2^ 1 - bitand ; inline
+
+M: float fp-nan?
+ dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
+
+M: float fp-qnan?
+ dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
+
+M: float fp-snan?
+ dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline
+
+M: float fp-infinity?
+ dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
+
+M: float next-float ( m -- n )
+ double>bits
+ dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
+ dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
+ 1 + bits>double ! positive
+ ] if
+ ] if ; inline
+
+M: float prev-float ( m -- n )
+ double>bits
+ dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
+ dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
+ 1 - bits>double ! positive non-zero
+ ] if
+ ] if ; inline
sequences.private math math.private combinators ;
IN: math.integers.private
-M: integer numerator ;
-M: integer denominator drop 1 ;
+M: integer numerator ; inline
+M: integer denominator drop 1 ; inline
-M: fixnum >fixnum ;
-M: fixnum >bignum fixnum>bignum ;
-M: fixnum >integer ;
+M: fixnum >fixnum ; inline
+M: fixnum >bignum fixnum>bignum ; inline
+M: fixnum >integer ; inline
-M: fixnum hashcode* nip ;
-M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
-M: fixnum number= eq? ;
+M: fixnum hashcode* nip ; inline
+M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
+M: fixnum number= eq? ; inline
-M: fixnum < fixnum< ;
-M: fixnum <= fixnum<= ;
-M: fixnum > fixnum> ;
-M: fixnum >= fixnum>= ;
+M: fixnum < fixnum< ; inline
+M: fixnum <= fixnum<= ; inline
+M: fixnum > fixnum> ; inline
+M: fixnum >= fixnum>= ; inline
-M: fixnum + fixnum+ ;
-M: fixnum - fixnum- ;
-M: fixnum * fixnum* ;
-M: fixnum /i fixnum/i ;
-M: fixnum /f [ >float ] dip >float float/f ;
+M: fixnum + fixnum+ ; inline
+M: fixnum - fixnum- ; inline
+M: fixnum * fixnum* ; inline
+M: fixnum /i fixnum/i ; inline
+M: fixnum /f [ >float ] dip >float float/f ; inline
-M: fixnum mod fixnum-mod ;
+M: fixnum mod fixnum-mod ; inline
-M: fixnum /mod fixnum/mod ;
+M: fixnum /mod fixnum/mod ; inline
-M: fixnum bitand fixnum-bitand ;
-M: fixnum bitor fixnum-bitor ;
-M: fixnum bitxor fixnum-bitxor ;
-M: fixnum shift >fixnum fixnum-shift ;
+M: fixnum bitand fixnum-bitand ; inline
+M: fixnum bitor fixnum-bitor ; inline
+M: fixnum bitxor fixnum-bitxor ; inline
+M: fixnum shift >fixnum fixnum-shift ; inline
-M: fixnum bitnot fixnum-bitnot ;
+M: fixnum bitnot fixnum-bitnot ; inline
-M: fixnum bit? neg shift 1 bitand 0 > ;
+M: fixnum bit? neg shift 1 bitand 0 > ; inline
: fixnum-log2 ( x -- n )
0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
-M: fixnum (log2) fixnum-log2 ;
+M: fixnum (log2) fixnum-log2 ; inline
-M: bignum >fixnum bignum>fixnum ;
-M: bignum >bignum ;
+M: bignum >fixnum bignum>fixnum ; inline
+M: bignum >bignum ; inline
M: bignum hashcode* nip >fixnum ;
M: bignum equal?
over bignum? [ bignum= ] [
swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
- ] if ;
+ ] if ; inline
-M: bignum number= bignum= ;
+M: bignum number= bignum= ; inline
-M: bignum < bignum< ;
-M: bignum <= bignum<= ;
-M: bignum > bignum> ;
-M: bignum >= bignum>= ;
+M: bignum < bignum< ; inline
+M: bignum <= bignum<= ; inline
+M: bignum > bignum> ; inline
+M: bignum >= bignum>= ; inline
-M: bignum + bignum+ ;
-M: bignum - bignum- ;
-M: bignum * bignum* ;
-M: bignum /i bignum/i ;
-M: bignum mod bignum-mod ;
+M: bignum + bignum+ ; inline
+M: bignum - bignum- ; inline
+M: bignum * bignum* ; inline
+M: bignum /i bignum/i ; inline
+M: bignum mod bignum-mod ; inline
-M: bignum /mod bignum/mod ;
+M: bignum /mod bignum/mod ; inline
-M: bignum bitand bignum-bitand ;
-M: bignum bitor bignum-bitor ;
-M: bignum bitxor bignum-bitxor ;
-M: bignum shift >fixnum bignum-shift ;
+M: bignum bitand bignum-bitand ; inline
+M: bignum bitor bignum-bitor ; inline
+M: bignum bitxor bignum-bitxor ; inline
+M: bignum shift >fixnum bignum-shift ; inline
-M: bignum bitnot bignum-bitnot ;
-M: bignum bit? bignum-bit? ;
-M: bignum (log2) bignum-log2 ;
+M: bignum bitnot bignum-bitnot ; inline
+M: bignum bit? bignum-bit? ; inline
+M: bignum (log2) bignum-log2 ; inline
! Converting ratios to floats. Based on FLOAT-RATIO from
! sbcl/src/code/float.lisp, which has the following license:
over zero? [
2drop 0.0
] [
- dup zero? [
- 2drop 1/0.
+ [
+ drop 1/0.
] [
pre-scale
/f-loop over odd?
[ zero? [ 1 + ] unless ] [ drop ] if
post-scale
- ] if
+ ] if-zero
] if ; inline
M: bignum /f ( m n -- f )
{ $description "Computes the bitwise complement of the input; that is, each bit in the input number is flipped." }
{ $notes "This word implements bitwise not, so applying it to booleans will throw an error. Boolean not is the " { $link not } " word."
$nl
-"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1-" } } ;
+"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1 -" } } ;
HELP: bit?
{ $values { "x" integer } { "n" integer } { "?" "a boolean" } }
{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." }
{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
-HELP: 1+
-{ $values { "x" number } { "y" number } }
-{ $description
- "Increments a number by 1. The following two lines are equivalent:"
- { $code "1+" "1 +" }
- "There is no difference in behavior or efficiency."
-} ;
-
-HELP: 1-
-{ $values { "x" number } { "y" number } }
-{ $description
- "Decrements a number by 1. The following two lines are equivalent:"
- { $code "1-" "1 -" }
- "There is no difference in behavior or efficiency."
-} ;
-
HELP: ?1+
{ $values { "x" { $maybe number } } { "y" number } }
{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
{ $description
"Outputs one of the following:"
{ $list
- "-1 if " { $snippet "x" } " is negative"
- "0 if " { $snippet "x" } " is equal to 0"
- "1 if " { $snippet "x" } " is positive"
+ { "-1 if " { $snippet "x" } " is negative" }
+ { "0 if " { $snippet "x" } " is equal to 0" }
+ { "1 if " { $snippet "x" } " is positive" }
}
} ;
{ $values { "x" number } { "?" "a boolean" } }
{ $description "Tests if the number is equal to zero." } ;
+HELP: if-zero
+{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ "3 [ \"zero\" ] [ sq ] if-zero ."
+ "9"
+} ;
+
+HELP: when-zero
+{ $values
+ { "n" number } { "quot" "the first quotation of an " { $link if-zero } } }
+{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:"
+ { $example
+ "USING: math prettyprint ;"
+ "0 [ 4 ] [ ] if-zero ."
+ "4"
+ }
+ { $example
+ "USING: math prettyprint ;"
+ "0 [ 4 ] when-zero ."
+ "4"
+ }
+} ;
+
+HELP: unless-zero
+{ $values
+ { "n" number } { "quot" "the second quotation of an " { $link if-empty } } }
+{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." }
+{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ ] [ sq ] if-empty ."
+ "9"
+ }
+ { $example
+ "USING: sequences math prettyprint ;"
+ "3 [ sq ] unless-zero ."
+ "9"
+ }
+} ;
+
HELP: times
{ $values { "n" integer } { "quot" quotation } }
{ $description "Calls the quotation " { $snippet "n" } " times." }
PRIVATE>
+ERROR: log2-expects-positive x ;
+
: log2 ( x -- n )
dup 0 <= [
- "log2 expects positive inputs" throw
+ log2-expects-positive
] [
(log2)
] if ; inline
: zero? ( x -- ? ) 0 number= ; inline
-: 1+ ( x -- y ) 1 + ; inline
-: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) -1 * ; inline
: even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ;
+: if-zero ( n quot1 quot2 -- )
+ [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+
+: when-zero ( n quot -- ) [ ] if-zero ; inline
+
+: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
+
UNION: integer fixnum bignum ;
TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ;
GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits )
-M: object fp-special?
- drop f ;
-M: object fp-nan?
- drop f ;
-M: object fp-qnan?
- drop f ;
-M: object fp-snan?
- drop f ;
-M: object fp-infinity?
- drop f ;
-M: object fp-nan-payload
- drop f ;
-
-M: float fp-special?
- double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
-
-M: float fp-nan-payload
- double>bits HEX: fffffffffffff bitand ; foldable flushable
-
-M: float fp-nan?
- dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
-
-M: float fp-qnan?
- dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
-
-M: float fp-snan?
- dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
-
-M: float fp-infinity?
- dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+M: object fp-special? drop f ; inline
+M: object fp-nan? drop f ; inline
+M: object fp-qnan? drop f ; inline
+M: object fp-snan? drop f ; inline
+M: object fp-infinity? drop f ; inline
+M: object fp-nan-payload drop f ; inline
: <fp-nan> ( payload -- nan )
- HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+ HEX: 7ff0000000000000 bitor bits>double ; inline
-: next-float ( m -- n )
- double>bits
- dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
- dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
- 1 + bits>double ! positive
- ] if
- ] if ; foldable flushable
-
-: prev-float ( m -- n )
- double>bits
- dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
- dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
- 1 - bits>double ! positive non-zero
- ] if
- ] if ; foldable flushable
+GENERIC: next-float ( m -- n )
+GENERIC: prev-float ( m -- n )
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
-M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )
GENERIC: before=? ( obj1 obj2 -- ? )
GENERIC: after=? ( obj1 obj2 -- ? )
-M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
-M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
-M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
-M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
+M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
+M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
+M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
+M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
-M: real before? ( obj1 obj2 -- ? ) < ;
-M: real after? ( obj1 obj2 -- ? ) > ;
-M: real before=? ( obj1 obj2 -- ? ) <= ;
-M: real after=? ( obj1 obj2 -- ? ) >= ;
+M: real before? ( obj1 obj2 -- ? ) < ; inline
+M: real after? ( obj1 obj2 -- ? ) > ; inline
+M: real before=? ( obj1 obj2 -- ? ) <= ; inline
+M: real after=? ( obj1 obj2 -- ? ) >= ; inline
-: min ( x y -- z ) [ before? ] most ; inline
+: min ( x y -- z ) [ before? ] most ; inline
: max ( x y -- z ) [ after? ] most ; inline
: clamp ( x min max -- y ) [ max ] dip min ; inline
[ "e" string>number ]
unit-test
+[ 100000 ]
+[ "100,000" string>number ]
+unit-test
+
+[ 100000.0 ]
+[ "100,000.0" string>number ]
+unit-test
+
[ "100.0" ]
[ "1.0e2" string>number number>string ]
unit-test
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
- } at 255 or ; inline
+ { CHAR: , f }
+ } at* [ drop 255 ] unless ; inline
: string>digits ( str -- digits )
[ digit> ] B{ } map-as ; inline
: (digits>integer) ( valid? accum digit radix -- valid? accum )
- 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+ over [
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
+ ] [ 2drop ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
] if ; inline
: string>float ( str -- n/f )
+ [ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ;
PRIVATE>
[
dup 0 < negative? set
abs 1 /mod
- [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
+ [ [ "" ] [ (>base) sign append ] if-zero ]
[
[ numerator (>base) ]
[ denominator (>base) ] bi
: <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
M: sbuf set-nth-unsafe
- [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline
M: sbuf new-sequence
- drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ;
+ drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; inline
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
M: sbuf like
drop dup sbuf? [
dup string? [ dup length sbuf boa ] [ >sbuf ] if
- ] unless ;
+ ] unless ; inline
-M: sbuf new-resizable drop <sbuf> ;
+M: sbuf new-resizable drop <sbuf> ; inline
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
-M: string new-resizable drop <sbuf> ;
+M: string new-resizable drop <sbuf> ; inline
M: string like
#! If we have a string, we're done.
2dup length eq?
[ nip dup reset-string-hashcode ] [ resize-string ] if
] [ >string ] if
- ] unless ;
+ ] unless ; inline
INSTANCE: sbuf growable
}
} ;
-{ if-empty when-empty unless-empty } related-words
-
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
{ $examples "Get random numbers until zero is reached:"
{ $unchecked-example
"USING: random sequences prettyprint math ;"
- "100 [ random dup zero? [ drop f ] when ] follow ."
+ "100 [ random [ f ] when-zero ] follow ."
"{ 100 86 34 32 24 11 7 2 }"
} } ;
$nl
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
+ARTICLE: "sequences-if" "Control flow with sequences"
+"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
+$nl
+"Checking if a sequence is empty:"
+{ $subsection if-empty }
+{ $subsection when-empty }
+{ $subsection unless-empty } ;
+
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
"Using sequences for looping:"
{ $subsection "sequences-integers" }
{ $subsection "math.ranges" }
+"Using sequences for control flow:"
+{ $subsection "sequences-if" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
: new-like ( len exemplar quot -- seq )
over [ [ new-sequence ] dip call ] dip like ; inline
-M: sequence like drop ;
+M: sequence like drop ; inline
GENERIC: lengthen ( n seq -- )
GENERIC: shorten ( n seq -- )
-M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
+M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline
-M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
: empty? ( seq -- ? ) length 0 = ; inline
GENERIC: nth-unsafe ( n seq -- elt ) flushable
GENERIC: set-nth-unsafe ( elt n seq -- )
-M: sequence nth bounds-check nth-unsafe ;
-M: sequence set-nth bounds-check set-nth-unsafe ;
+M: sequence nth bounds-check nth-unsafe ; inline
+M: sequence set-nth bounds-check set-nth-unsafe ; inline
-M: sequence nth-unsafe nth ;
-M: sequence set-nth-unsafe set-nth ;
+M: sequence nth-unsafe nth ; inline
+M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- )
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
! The f object supports the sequence protocol trivially
-M: f length drop 0 ;
-M: f nth-unsafe nip ;
-M: f like drop [ f ] when-empty ;
+M: f length drop 0 ; inline
+M: f nth-unsafe nip ; inline
+M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence
! Integers support the sequence protocol
-M: integer length ;
-M: integer nth-unsafe drop ;
+M: integer length ; inline
+M: integer nth-unsafe drop ; inline
INSTANCE: integer immutable-sequence
<PRIVATE
-M: iota length n>> ;
-M: iota nth-unsafe drop ;
+M: iota length n>> ; inline
+M: iota nth-unsafe drop ; inline
INSTANCE: iota immutable-sequence
GENERIC: virtual-seq ( seq -- seq' )
GENERIC: virtual@ ( n seq -- n' seq' )
-M: virtual-sequence nth virtual@ nth ;
-M: virtual-sequence set-nth virtual@ set-nth ;
-M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
-M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
-M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new-sequence virtual-seq new-sequence ;
+M: virtual-sequence nth virtual@ nth ; inline
+M: virtual-sequence set-nth virtual@ set-nth ; inline
+M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
+M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
+M: virtual-sequence like virtual-seq like ; inline
+M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
INSTANCE: virtual-sequence sequence
C: <reversed> reversed
-M: reversed virtual-seq seq>> ;
-
-M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
-
-M: reversed length seq>> length ;
+M: reversed virtual-seq seq>> ; inline
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
+M: reversed length seq>> length ; inline
INSTANCE: reversed virtual-sequence
check-slice
slice boa ; inline
-M: slice virtual-seq seq>> ;
+M: slice virtual-seq seq>> ; inline
-M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
+M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline
-M: slice length [ to>> ] [ from>> ] bi - ;
+M: slice length [ to>> ] [ from>> ] bi - ; inline
: short ( seq n -- seq n' ) over length min ; inline
C: <repetition> repetition
-M: repetition length len>> ;
-M: repetition nth-unsafe nip elt>> ;
+M: repetition length len>> ; inline
+M: repetition nth-unsafe nip elt>> ; inline
INSTANCE: repetition immutable-sequence
<PRIVATE
+ERROR: integer-length-expected obj ;
+
: check-length ( n -- n )
#! Ricing.
- dup integer? [ "length not an integer" throw ] unless ; inline
+ dup integer? [ integer-length-expected ] unless ; inline
: ((copy)) ( dst i src j n -- dst i src j n )
dup -roll [
(copy) drop ; inline
M: sequence clone-like
- [ dup length ] dip new-sequence [ 0 swap copy ] keep ;
+ [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline
-M: immutable-sequence clone-like like ;
+M: immutable-sequence clone-like like ; inline
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
-IN: slots.tests
USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
+IN: slots.tests
TUPLE: r/w-test foo ;
[ "xyz" 4 >>length ] [ no-method? ] must-fail-with
-[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test
-
-[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
-! See if declarations are cleared on redefinition
-[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
-
-[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
-[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
-
-[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
! Test protocol slots
SLOT: my-protocol-slot-test
T{ protocol-slot-test-tuple { x 3 } } clone
[ 7 + ] change-my-protocol-slot-test x>>
] unit-test
+
+UNION: comme-ci integer float ;
+UNION: comme-ca integer float ;
+comme-ca 25.5 "initial-value" set-word-prop
+
+[ 0 ] [ comme-ci initial-value ] unit-test
+[ 25.5 ] [ comme-ca initial-value ] unit-test
[ create-method ] 2dip
[ [ props>> ] [ drop ] [ ] tri* update ]
[ drop define ]
- 3bi ;
+ [ 2drop make-inline ]
+ 3tri ;
GENERIC# reader-quot 1 ( class slot-spec -- quot )
dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc )
- [
- [ "reading" set ]
- [ read-only>> [ t "foldable" set ] when ] bi
- t "flushable" set
- ] H{ } make-assoc ;
+ "reading" associate ;
: define-reader-generic ( name -- )
reader-word (( object -- value )) define-simple-generic ;
: initial-value ( class -- object )
{
+ { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] }
{ [ \ f bootstrap-word over class<= ] [ f ] }
{ [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
{ [ float bootstrap-word over class<= ] [ 0.0 ] }
: finalize-slots ( specs base -- specs )
over length iota [ + ] with map [ >>offset ] 2map ;
+: slot-named* ( name specs -- offset spec/f )
+ [ name>> = ] with find ;
+
: slot-named ( name specs -- spec/f )
- [ name>> = ] with find nip ;
+ slot-named* nip ;
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
- [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
+ [ swap [ tail ] unless-zero , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
[ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length
- length>> ;
+ length>> ; inline
M: string nth-unsafe
- [ >fixnum ] dip string-nth ;
+ [ >fixnum ] dip string-nth ; inline
M: string set-nth-unsafe
dup reset-string-hashcode
- [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline
M: string clone
- (clone) [ clone ] change-aux ;
+ (clone) [ clone ] change-aux ; inline
-M: string resize resize-string ;
+M: string resize resize-string ; inline
: 1string ( ch -- str ) 1 swap <string> ;
: >string ( seq -- str ) "" clone-like ;
-M: string new-sequence drop 0 <string> ;
+M: string new-sequence drop 0 <string> ; inline
INSTANCE: string sequence
{ $syntax ": foo ... ; delimiter" }
{ $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ;
+HELP: deprecated
+{ $syntax ": foo ... ; deprecated" }
+{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ;
+
HELP: SYNTAX:
{ $syntax "SYNTAX: foo ... ;" }
{ $description "Defines a parsing word." }
"foldable" [ word make-foldable ] define-core-syntax
"flushable" [ word make-flushable ] define-core-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
+ "deprecated" [ word make-deprecated ] define-core-syntax
"SYNTAX:" [
CREATE-WORD parse-definition define-syntax
M: vector like
drop dup vector? [
dup array? [ dup length vector boa ] [ >vector ] if
- ] unless ;
+ ] unless ; inline
M: vector new-sequence
- drop [ f <array> ] [ >fixnum ] bi vector boa ;
+ drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
2dup length eq?
[ nip ] [ resize-array ] if
] [ >array ] if
- ] unless ;
+ ] unless ; inline
-M: sequence new-resizable drop <vector> ;
+M: sequence new-resizable drop <vector> ; inline
INSTANCE: vector growable
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
+HELP: deprecated?
+{ $values { "obj" object } { "?" "a boolean" } }
+{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." }
+{ $notes "Outputs " { $link f } " if the object is not a word." } ;
+
+HELP: make-deprecated
+{ $values { "word" word } }
+{ $description "Declares a word as " { $link POSTPONE: deprecated } "." }
+{ $side-effects "word" } ;
+
HELP: make-flushable
{ $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: flushable } "." }
[
all-words [
"compiled-uses" word-prop
- keys [ "forgotten" word-prop ] any?
- ] filter
+ keys [ "forgotten" word-prop ] filter
+ ] map harvest
] unit-test
M: word execute (execute) ;
-M: word ?execute execute( -- value ) ;
+M: word ?execute execute( -- value ) ; inline
M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
: define-declared ( word def effect -- )
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
+: make-deprecated ( word -- )
+ t "deprecated" set-word-prop ;
+
: make-inline ( word -- )
dup inline? [ drop ] [
[ t "inline" set-word-prop ]
{
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
- "writer" "delimiter"
+ "writer" "delimiter" "deprecated"
} reset-props ;
: reset-generic ( word -- )
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
+: deprecated? ( obj -- ? )
+ dup word? [ "deprecated" word-prop ] [ drop f ] if ;
+
! Definition protocol
M: word where "loc" word-prop ;
] if ;
M: word hashcode*
- nip 1 slot { fixnum } declare ; foldable
+ nip 1 slot { fixnum } declare ; inline foldable
M: word literalize <wrapper> ;
-INSTANCE: word definition
\ No newline at end of file
+INSTANCE: word definition
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
-: dimension ( array -- x ) length 1- ; inline \r
+: dimension ( array -- x ) length 1 - ; inline \r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
position-point VERY-SMALL-NUM neg > ;\r
: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1+ tail ] 2bi append ; \r
+ pv> [ head ] [ 1 + tail ] 2bi append ; \r
: get-intersection ( matrice -- seq ) \r
[ 1 tail* ] map flip first ;\r
\r
: compute-adjacencies ( solid -- solid )\r
dup dimension>> [ >= ] curry \r
[ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] while drop ;\r
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
\r
: find-adjacencies ( solid -- solid ) \r
erase-old-adjacencies \r
[ [ non-empty-solid? ] filter ] change-solids ;\r
\r
: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> \r
+ swap dimension>> 1 - <space> \r
swap >>dimension swap >>solids ;\r
\r
: get-silhouette ( solid -- silhouette ) \r
! { [ dup 0 = ] [ 2drop { { } } ] }\r
! { [ over empty? ] [ 2drop { } ] }\r
! { [ t ] [ \r
-! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
! [ (combinations) ] 2bi append\r
! ] }\r
! } cond ;\r
{ [ over 1 = ] [ 3drop columnize ] }\r
{ [ over 0 = ] [ 2drop 2drop { } ] }\r
{ [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1- among [ append ] with map ] \r
+ [ 1 - among [ append ] with map ] \r
[ among append ] 2bi\r
] }\r
{ [ 2dup = ] [ 3drop 1array ] }\r
: do-row ( exchange-with row# -- )\r
[ exchange-rows ] keep\r
[ first-col ] keep\r
- dup 1+ rows-from clear-col ;\r
+ dup 1 + rows-from clear-col ;\r
\r
: find-row ( row# quot -- i elt )\r
[ rows-from ] dip find ; inline\r
\r
: (echelon) ( col# row# -- )\r
over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1+ ] when*\r
- [ 1+ ] dip (echelon)\r
+ 2dup pivot-row [ over do-row 1 + ] when*\r
+ [ 1 + ] dip (echelon)\r
] [\r
2drop\r
] if ;\r
: four ( -- x )
!BROKEN this code is broken
- 2 2 + 1+ ;
+ 2 2 + 1 + ;
: five ( -- x )
!TODO return 5
remaining 1 <= [
listener call f
] [
- remaining 1-
+ remaining 1 -
0
value' 10 *
used mask bitor
] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
+ 10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
[let | i! [ 0 ] |
- 5000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1 + i! ] count-numbers
i number>string " unique numbers." append print
] ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+concurrency.mailboxes fry io kernel make math math.parser
+math.text.english sequences threads ;
+IN: benchmark.chameneos-redux
+
+SYMBOLS: red yellow blue ;
+
+ERROR: bad-color-pair pair ;
+
+TUPLE: creature n color count self-count mailbox ;
+
+TUPLE: meeting-place count mailbox ;
+
+: <meeting-place> ( count -- meeting-place )
+ meeting-place new
+ swap >>count
+ <mailbox> >>mailbox ;
+
+: <creature> ( n color -- creature )
+ creature new
+ swap >>color
+ swap >>n
+ 0 >>count
+ 0 >>self-count
+ <mailbox> >>mailbox ;
+
+: make-creatures ( colors -- seq )
+ [ length iota ] [ ] bi [ <creature> ] 2map ;
+
+: complement-color ( color1 color2 -- color3 )
+ 2dup = [ drop ] [
+ 2array {
+ { { red yellow } [ blue ] }
+ { { red blue } [ yellow ] }
+ { { yellow red } [ blue ] }
+ { { yellow blue } [ red ] }
+ { { blue red } [ yellow ] }
+ { { blue yellow } [ red ] }
+ [ bad-color-pair ]
+ } case
+ ] if ;
+
+: color-string ( color1 color2 -- string )
+ [
+ [ [ name>> ] bi@ " + " glue % " -> " % ]
+ [ complement-color name>> % ] 2bi
+ ] "" make ;
+
+: print-color-table ( -- )
+ { blue red yellow } dup
+ '[ _ '[ color-string print ] with each ] each ;
+
+: try-meet ( meeting-place creature -- )
+ over count>> 0 < [
+ 2drop
+ ] [
+ [ swap mailbox>> mailbox-put ]
+ [ nip mailbox>> mailbox-get drop ]
+ [ try-meet ] 2tri
+ ] if ;
+
+: creature-meeting ( seq -- )
+ first2 {
+ [ [ [ 1 + ] change-count ] bi@ 2drop ]
+ [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
+ [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ]
+ [ [ mailbox>> f swap mailbox-put ] bi@ ]
+ } 2cleave ;
+
+: run-meeting-place ( meeting-place -- )
+ [ 1 - ] change-count
+ dup count>> 0 < [
+ mailbox>> mailbox-get-all
+ [ f swap mailbox>> mailbox-put ] each
+ ] [
+ [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
+ [ run-meeting-place ] bi
+ ] if ;
+
+: number>chameneos-string ( n -- string )
+ number>string string>digits [ number>text ] { } map-as " " join ;
+
+: chameneos-redux ( n colors -- )
+ [ <meeting-place> ] [ make-creatures ] bi*
+ {
+ [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
+ [ [ '[ _ _ try-meet ] in-thread ] with each ]
+ [ drop run-meeting-place ]
+
+ [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ]
+ [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ]
+ } 2cleave ;
+
+! 6000000 for shootout, too slow right now
+
+: chameneos-redux-main ( -- )
+ print-color-table
+ 60000 [
+ { blue red yellow } chameneos-redux
+ ] [
+ { blue red yellow red yellow blue red yellow red blue } chameneos-redux
+ ] bi ;
+
+MAIN: chameneos-redux-main
: count ( quot: ( -- ? ) -- n )
#! Call quot until it returns false, return number of times
#! it was true
- [ 0 ] dip '[ _ dip swap [ [ 1+ ] when ] keep ] loop ; inline
+ [ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline
: count-flips ( perm -- flip# )
'[
[ CHAR: 0 + write1 ] each nl ; inline
: fannkuch-step ( counter max-flips perm -- counter max-flips )
- pick 30 < [ [ 1+ ] [ ] [ dup write-permutation ] tri* ] when
+ pick 30 < [ [ 1 + ] [ ] [ dup write-permutation ] tri* ] when
count-flips max ; inline
: fannkuch ( n -- )
[
- [ 0 0 ] dip [ 1+ ] B{ } map-as
+ [ 0 0 ] dip [ 1 + ] B{ } map-as
[ fannkuch-step ] each-permutation nip
] keep
"Pfannkuchen(" write pprint ") = " write . ;
:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
- dup zero? [ drop ] quot if ; inline
+ quot unless-zero ; inline
: write-random-fasta ( seed n chars floats desc id -- seed )
write-description
dup i>> 1 <= [
drop 1 <box>
] [
- i>> 1- <box>
+ i>> 1 - <box>
dup tuple-fib
swap
- i>> 1- <box>
+ i>> 1 - <box>
tuple-fib
swap i>> swap i>> + <box>
] if ; inline recursive
-IN: benchmark.fib6\r
USING: math kernel alien ;\r
+IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
"int" { "int" } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
- 1- dup fib swap 1- fib +\r
+ 1 - dup fib swap 1 - fib +\r
] if\r
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
+: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
-MAIN: gc1
\ No newline at end of file
+MAIN: gc1
: tally ( x exemplar -- b )
clone tuck
[
- [ [ 1+ ] [ 1 ] if* ] change-at
+ [ [ 1 + ] [ 1 ] if* ] change-at
] curry each ;
: small-groups ( x n -- b )
swap
- [ length swap - 1+ ] 2keep
+ [ length swap - 1 + ] 2keep
[ [ over + ] dip subseq ] 2curry map ;
: handle-table ( inputs n -- )
: <color-map> ( nb-cols -- map )
dup [
- 360 * swap 1+ / sat val
+ 360 * swap 1 + / sat val
1 <hsva> >rgba scale-rgb
] with map ;
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
bodies [| body i |
body each-quot call
- bodies i 1+ tail-slice [
+ bodies i 1 + tail-slice [
body pair-quot call
] each
] each-index ; inline
-IN: benchmark.nsieve-bits
USING: math math.parser sequences sequences.private kernel
bit-arrays make io ;
+IN: benchmark.nsieve-bits
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve-bits)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve-bits)
] [
2drop
] if ; inline recursive
: nsieve-bits ( m -- count )
- 0 2 rot 1+ <bit-array> dup set-bits (nsieve-bits) ;
+ 0 2 rot 1 + <bit-array> dup set-bits (nsieve-bits) ;
: nsieve-bits. ( m -- )
[ "Primes up to " % dup # " " % nsieve-bits # ] "" make
: nsieve-bits-main ( n -- )
dup 2^ 10000 * nsieve-bits.
- dup 1- 2^ 10000 * nsieve-bits.
+ dup 1 - 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
2dup length < [
2dup nth-unsafe 0 > [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ <byte-array> dup [ drop 1 ] change-each (nsieve) ;
+ 0 2 rot 1 + <byte-array> dup [ drop 1 ] change-each (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
-IN: benchmark.nsieve
USING: math math.parser sequences sequences.private kernel
arrays make io ;
+IN: benchmark.nsieve
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ t <array> (nsieve) ;
+ 0 2 rot 1
+ t <array> (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
IN: benchmark.partial-sums
! Helper words
-: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
+: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
: cube ( x -- y ) dup dup * * ; inline
-: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
+: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline
! The functions
-: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
+: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1 - ^ ] summing-floats ; inline
: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
-: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
+: 1/k(k+1) ( n -- y ) [ dup 1 + * recip ] summing-floats ; inline
: flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
: cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
: harmonic ( n -- y ) [ recip ] summing-floats ; inline
: riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
: alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
-: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
+: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1 - ] bi / ] summing-integers ; inline
: partial-sums ( n -- results )
[
: ack ( m n -- x )
{
- { [ over zero? ] [ nip 1+ ] }
- { [ dup zero? ] [ drop 1- 1 ack ] }
- [ [ drop 1- ] [ 1- ack ] 2bi ack ]
+ { [ over zero? ] [ nip 1 + ] }
+ { [ dup zero? ] [ drop 1 - 1 ack ] }
+ [ [ drop 1 - ] [ 1 - ack ] 2bi ack ]
} cond ; inline recursive
: tak ( x y z -- t )
2over <= [
2nip
] [
- [ rot 1- -rot tak ]
- [ -rot 1- -rot tak ]
- [ 1- -rot tak ]
+ [ rot 1 - -rot tak ]
+ [ -rot 1 - -rot tak ]
+ [ 1 - -rot tak ]
3tri
tak
] if ; inline recursive
: recursive ( n -- )
[ 3 swap ack . flush ]
[ 27.0 + fib . flush ]
- [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
+ [ 1 - [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
: tuple-array-benchmark ( -- )
100 [
drop 5000 <point-array> [
- [ 1+ ] change-x
- [ 1- ] change-y
- [ 1+ 2 / ] change-z
+ [ 1 + ] change-x
+ [ 1 - ] change-y
+ [ 1 + 2 / ] change-z
] map [ z>> ] sigma
] sigma . ;
-MAIN: tuple-array-benchmark
\ No newline at end of file
+MAIN: tuple-array-benchmark
255 min 0 max ; inline
: stride ( line yuv -- uvy yy )
- [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
- [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
+ [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
: compute-y ( yuv uvy yy x -- y )
+ >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
drop ; inline
: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
- compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+ compute-yuv compute-rgb store-rgb 3 + ; inline
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
- pick yuv_buffer-y_width >fixnum
+ pick yuv_buffer-y_width
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
- dup yuv_buffer-y_height >fixnum
+ dup yuv_buffer-y_height
[ yuv>rgb-row ] with with each
drop ;
: next-draw ( gadget -- )
dup [ draw-seq>> ] [ draw-n>> ] bi
- 1+ swap length mod
+ 1 + swap length mod
>>draw-n relayout-1 ;
: make-draws ( gadget -- draw-seq )
TUPLE: test-disp-cent value disposed ;
! A phony destructor that adds 1 to the value so we can make sure it got called.
-M: test-disp-cent dispose* dup value>> 1+ >>value drop ;
+M: test-disp-cent dispose* dup value>> 1 + >>value drop ;
DISPOSABLE-CENTRAL: t-d-c
: test-t-d-c ( -- n )
test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
-[ 4 ] [ test-t-d-c ] unit-test
\ No newline at end of file
+[ 4 ] [ test-t-d-c ] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien arrays classes help.markup help.syntax kernel math
+specialized-arrays.direct ;
+IN: classes.c-types
+
+HELP: c-type-class
+{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
+
+HELP: char
+{ $class-description "A signed one-byte integer quantity." } ;
+
+HELP: direct-array-of
+{ $values
+ { "alien" c-ptr } { "len" integer } { "class" c-type-class }
+ { "array" "a direct array" }
+}
+{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
+
+HELP: int
+{ $class-description "A signed four-byte integer quantity." } ;
+
+HELP: long
+{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
+
+HELP: longlong
+{ $class-description "A signed eight-byte integer quantity." } ;
+
+HELP: short
+{ $class-description "A signed two-byte integer quantity." } ;
+
+HELP: single-complex
+{ $class-description "A single-precision complex floating point quantity." } ;
+
+HELP: single-float
+{ $class-description "A single-precision floating point quantity." } ;
+
+HELP: uchar
+{ $class-description "An unsigned one-byte integer quantity." } ;
+
+HELP: uint
+{ $class-description "An unsigned four-byte integer quantity." } ;
+
+HELP: ulong
+{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
+
+HELP: ulonglong
+{ $class-description "An unsigned eight-byte integer quantity." } ;
+
+HELP: ushort
+{ $class-description "An unsigned two-byte integer quantity." } ;
+
+ARTICLE: "classes.c-types" "C type classes"
+"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
+{ $subsection char }
+{ $subsection uchar }
+{ $subsection short }
+{ $subsection ushort }
+{ $subsection int }
+{ $subsection uint }
+{ $subsection long }
+{ $subsection ulong }
+{ $subsection longlong }
+{ $subsection ulonglong }
+{ $subsection single-float }
+{ $subsection float }
+{ $subsection single-complex }
+{ $subsection complex }
+{ $subsection pinned-c-ptr }
+"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
+{ $subsection direct-array-of } ;
+
+ABOUT: "classes.c-types"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien alien.c-types classes classes.predicate kernel
+math math.bitwise math.order namespaces sequences words
+specialized-arrays.direct.alien
+specialized-arrays.direct.bool
+specialized-arrays.direct.char
+specialized-arrays.direct.complex-double
+specialized-arrays.direct.complex-float
+specialized-arrays.direct.double
+specialized-arrays.direct.float
+specialized-arrays.direct.int
+specialized-arrays.direct.long
+specialized-arrays.direct.longlong
+specialized-arrays.direct.short
+specialized-arrays.direct.uchar
+specialized-arrays.direct.uint
+specialized-arrays.direct.ulong
+specialized-arrays.direct.ulonglong
+specialized-arrays.direct.ushort ;
+IN: classes.c-types
+
+PREDICATE: char < fixnum
+ HEX: -80 HEX: 7f between? ;
+
+PREDICATE: uchar < fixnum
+ HEX: 0 HEX: ff between? ;
+
+PREDICATE: short < fixnum
+ HEX: -8000 HEX: 7fff between? ;
+
+PREDICATE: ushort < fixnum
+ HEX: 0 HEX: ffff between? ;
+
+PREDICATE: int < integer
+ HEX: -8000,0000 HEX: 7fff,ffff between? ;
+
+PREDICATE: uint < integer
+ HEX: 0 HEX: ffff,ffff between? ;
+
+PREDICATE: longlong < integer
+ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
+
+PREDICATE: ulonglong < integer
+ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
+
+UNION: single-float float ;
+UNION: single-complex complex ;
+
+SYMBOLS: long ulong long-bits ;
+
+<<
+ "long" heap-size 8 =
+ [
+ \ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
+ \ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
+ 64 \ long-bits set-global
+ ] [
+ \ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
+ \ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class
+ 32 \ long-bits set-global
+ ] if
+>>
+
+: set-class-c-type ( class initial c-type <direct-array> -- )
+ [ "initial-value" set-word-prop ]
+ [ c-type "class-c-type" set-word-prop ]
+ [ "class-direct-array" set-word-prop ] tri-curry* tri ;
+
+: class-c-type ( class -- c-type )
+ "class-c-type" word-prop ;
+: class-direct-array ( class -- <direct-array> )
+ "class-direct-array" word-prop ;
+
+\ f f "void*" \ <direct-void*-array> set-class-c-type
+pinned-c-ptr f "void*" \ <direct-void*-array> set-class-c-type
+boolean f "bool" \ <direct-bool-array> set-class-c-type
+char 0 "char" \ <direct-char-array> set-class-c-type
+uchar 0 "uchar" \ <direct-uchar-array> set-class-c-type
+short 0 "short" \ <direct-short-array> set-class-c-type
+ushort 0 "ushort" \ <direct-ushort-array> set-class-c-type
+int 0 "int" \ <direct-int-array> set-class-c-type
+uint 0 "uint" \ <direct-uint-array> set-class-c-type
+long 0 "long" \ <direct-long-array> set-class-c-type
+ulong 0 "ulong" \ <direct-ulong-array> set-class-c-type
+longlong 0 "longlong" \ <direct-longlong-array> set-class-c-type
+ulonglong 0 "ulonglong" \ <direct-ulonglong-array> set-class-c-type
+float 0.0 "double" \ <direct-double-array> set-class-c-type
+single-float 0.0 "float" \ <direct-float-array> set-class-c-type
+complex C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
+single-complex C{ 0.0 0.0 } "complex-float" \ <direct-complex-float-array> set-class-c-type
+
+char [ 8 bits 8 >signed ] "coercer" set-word-prop
+uchar [ 8 bits ] "coercer" set-word-prop
+short [ 16 bits 16 >signed ] "coercer" set-word-prop
+ushort [ 16 bits ] "coercer" set-word-prop
+int [ 32 bits 32 >signed ] "coercer" set-word-prop
+uint [ 32 bits ] "coercer" set-word-prop
+long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
+ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop
+longlong [ 64 bits 64 >signed ] "coercer" set-word-prop
+ulonglong [ 64 bits ] "coercer" set-word-prop
+
+PREDICATE: c-type-class < class
+ "class-c-type" word-prop ;
+
+GENERIC: direct-array-of ( alien len class -- array ) inline
+
+M: c-type-class direct-array-of
+ class-direct-array execute( alien len -- array ) ; inline
+
+M: c-type-class c-type class-c-type ;
+M: c-type-class c-type-align class-c-type c-type-align ;
+M: c-type-class c-type-getter class-c-type c-type-getter ;
+M: c-type-class c-type-setter class-c-type c-type-setter ;
+M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
+M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
+M: c-type-class heap-size class-c-type heap-size ;
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors assocs classes classes.struct kernel math
+prettyprint.backend prettyprint.custom prettyprint.sections
+see.private sequences words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+ struct-slots dup length 2 >=
+ [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+ [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+ [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+PRIVATE>
+
+M: struct-class see-class*
+ <colon dup struct-definer-word pprint-word dup pprint-word
+ <block struct-slots [ pprint-slot ] each
+ block> pprint-; block> ;
+
+M: struct pprint-delims
+ drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+ [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+ [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+ { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: <struct>
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." }
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+ { "class" class }
+ { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+ { "ptr" c-ptr } { "class" class }
+ { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien.c-types alien.structs.fields classes.c-types
+classes.struct combinators io.streams.string kernel libc literals math
+multiline namespaces prettyprint prettyprint.config see tools.test ;
+IN: classes.struct.tests
+
+STRUCT: struct-test-foo
+ { x char }
+ { y int initial: 123 }
+ { z boolean } ;
+
+STRUCT: struct-test-bar
+ { w ushort initial: HEX: ffff }
+ { foo struct-test-foo } ;
+
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+ 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
+ {
+ [ w>> ]
+ [ foo>> x>> ]
+ [ foo>> y>> ]
+ [ foo>> z>> ]
+ } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+ { f single-float }
+ { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ ] [ struct-test-foo malloc-struct free ] unit-test
+
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+ f boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+ t boa-tuples?
+ [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+ with-variable
+] unit-test
+
+[ <" USING: classes.c-types classes.struct kernel ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+ { x char initial: 0 } { y int initial: 123 }
+ { z boolean initial: f } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.c-types classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+ { f single-float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+ T{ field-spec
+ { name "x" }
+ { offset 0 }
+ { type $[ char c-type ] }
+ { reader x>> }
+ { writer (>>x) }
+ }
+ T{ field-spec
+ { name "y" }
+ { offset 4 }
+ { type $[ int c-type ] }
+ { reader y>> }
+ { writer (>>y) }
+ }
+ T{ field-spec
+ { name "z" }
+ { offset 8 }
+ { type $[ boolean c-type ] }
+ { reader z>> }
+ { writer (>>z) }
+ }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+ T{ field-spec
+ { name "f" }
+ { offset 0 }
+ { type $[ single-float c-type ] }
+ { reader f>> }
+ { writer (>>f) }
+ }
+ T{ field-spec
+ { name "bits" }
+ { offset 0 }
+ { type $[ uint c-type ] }
+ { reader bits>> }
+ { writer (>>bits) }
+ }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
+byte-arrays classes classes.c-types classes.parser classes.tuple
+classes.tuple.parser classes.tuple.private combinators
+combinators.smart fry generalizations generic.parser kernel
+kernel.private libc macros make math math.order parser
+quotations sequences slots slots.private struct-arrays words ;
+FROM: slots => reader-word writer-word ;
+IN: classes.struct
+
+! struct class
+
+TUPLE: struct
+ { (underlying) c-ptr read-only } ;
+
+PREDICATE: struct-class < tuple-class
+ \ struct subclass-of? ;
+
+: struct-slots ( struct -- slots )
+ "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+ 2 slot { c-ptr } declare ; inline
+
+: memory>struct ( ptr class -- struct )
+ over c-ptr? [ swap \ c-ptr bad-slot-value ] unless
+ tuple-layout <tuple> [ 2 set-slot ] keep ;
+
+: malloc-struct ( class -- struct )
+ [ heap-size malloc ] keep memory>struct ; inline
+
+: (struct) ( class -- struct )
+ [ heap-size <byte-array> ] keep memory>struct ; inline
+
+: <struct> ( class -- struct )
+ dup "prototype" word-prop
+ [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+ [
+ [ <wrapper> \ (struct) [ ] 2sequence ]
+ [
+ struct-slots
+ [ length \ ndip ]
+ [ [ name>> setter-word 1quotation ] map \ spread ] bi
+ ] bi
+ ] [ ] output>sequence ;
+
+: pad-struct-slots ( values class -- values' class )
+ [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+ [ class>> c-type-getter-boxer ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+ [ class>> c-setter ]
+ [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+ '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+ drop [ >c-ptr ] ;
+
+M: struct-class boa>object
+ swap pad-struct-slots
+ [ (struct) ] [ struct-slots ] bi
+ [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+ nip (reader-quot) ;
+
+M: struct-class writer-quot
+ nip (writer-quot) ;
+
+: struct-slot-values-quot ( class -- quot )
+ struct-slots
+ [ name>> reader-word 1quotation ] map
+ \ cleave [ ] 2sequence
+ \ output>array [ ] 2sequence ;
+
+: (define-struct-slot-values-method) ( class -- )
+ [ \ struct-slot-values create-method-in ]
+ [ struct-slot-values-quot ] bi define ;
+
+! Struct as c-type
+
+: slot>field ( slot -- field )
+ field-spec new swap {
+ [ name>> >>name ]
+ [ offset>> >>offset ]
+ [ class>> c-type >>type ]
+ [ name>> reader-word >>reader ]
+ [ name>> writer-word >>writer ]
+ } cleave ;
+
+: define-struct-for-class ( class -- )
+ [
+ {
+ [ name>> ]
+ [ "struct-size" word-prop ]
+ [ "struct-align" word-prop ]
+ [ struct-slots [ slot>field ] map ]
+ } cleave
+ (define-struct)
+ ] [
+ [ name>> c-type ]
+ [ (unboxer-quot) >>unboxer-quot ]
+ [ (boxer-quot) >>boxer-quot ] tri drop
+ ] bi ;
+
+: align-offset ( offset class -- offset' )
+ c-type-align align ;
+
+: struct-offsets ( slots -- size )
+ 0 [
+ [ class>> align-offset ] keep
+ [ (>>offset) ] [ class>> heap-size + ] 2bi
+ ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+ [ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+ [ class>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class c-type
+ name>> c-type ;
+
+M: struct-class c-type-align
+ "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+ drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+ [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+ '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+ (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+ (unboxer-quot) ;
+
+M: struct-class heap-size
+ "struct-size" word-prop ;
+
+M: struct-class direct-array-of
+ <direct-struct-array> ;
+
+! class definition
+
+: struct-prototype ( class -- prototype )
+ [ heap-size <byte-array> ]
+ [ memory>struct ]
+ [ struct-slots ] tri
+ [
+ [ initial>> ]
+ [ (writer-quot) ] bi
+ over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+ ] each ;
+
+: (struct-word-props) ( class slots size align -- )
+ [
+ [ "struct-slots" set-word-prop ]
+ [ define-accessors ] 2bi
+ ]
+ [ "struct-size" set-word-prop ]
+ [ "struct-align" set-word-prop ] tri-curry*
+ [ tri ] 3curry
+ [ dup struct-prototype "prototype" set-word-prop ]
+ [ (define-struct-slot-values-method) ] tri ;
+
+: check-struct-slots ( slots -- )
+ [ class>> c-type drop ] each ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+ [ drop struct f define-tuple-class ]
+ swap '[
+ make-slots dup
+ [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+ (struct-word-props)
+ ]
+ [ drop define-struct-for-class ] 2tri ; inline
+
+: define-struct-class ( class slots -- )
+ [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+ [ union-struct-offsets ] (define-struct-class) ;
+
+: parse-struct-definition ( -- class slots )
+ CREATE-CLASS [ parse-tuple-slots ] { } make ;
+
+SYNTAX: STRUCT:
+ parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+ parse-struct-definition define-union-struct-class ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
+
+SYNTAX: S{
+ scan-word dup struct-slots parse-tuple-literal-slots parsed ;
[ drop 1 coyield* 2 coyield* 3 coterminate ] cocreate ;
: test2 ( -- co )
- [ 1+ coyield* ] cocreate ;
+ [ 1 + coyield* ] cocreate ;
test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
[ test2 42 over coresume . dup *coresume . drop ] must-fail
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test
-{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
+{ 4+2/3 } [ [ 1 + coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- [ [ log2 1+ ] [ / 2 * ] bi* ]
+ [ [ log2 1 + ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
"./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline
: to64 ( v n -- string )
- [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ]
+ [ [ -6 shift ] [ 6 2^ 1 - bitand lookup-table ] bi ]
replicate nip ; inline
PRIVATE>
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
- [ 1- ] bi@ *
+ [ 1 - ] bi@ *
dup public-key gcd nip 1 = [
rot drop
] [
H{ } clone swap [ swap [ etag-add ] keep ] each ;
: lines>bytes ( seq n -- bytes )
- head 0 [ length 1+ + ] reduce ;
+ head 0 [ length 1 + + ] reduce ;
: file>lines ( path -- lines )
ascii file-lines ;
1 HEX: 7f <string> %
second dup number>string %
1 CHAR: , <string> %
- 1- lines>bytes number>string %
+ 1 - lines>bytes number>string %
] "" make ;
: etag-length ( vector -- n )
[ etag-strings ] dip ascii set-file-lines ;
: etags ( path -- )
- [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
\ No newline at end of file
+ [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
>from-sequence< nth-unsafe ;
M: from-sequence cursor-advance
- [ 1+ ] change-n drop ;
+ [ 1 + ] change-n drop ;
: >input ( seq -- cursor )
0 from-sequence boa ; inline
-USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ;\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see\r
+math.ratios ;\r
IN: descriptive.tests\r
\r
DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
\r
[ 3 ] [ 9 3 divide ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test\r
\r
-[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide\r
+ }\r
+] [\r
+ [ 3 0 divide ] [ ] recover\r
+] unit-test\r
+\r
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ]\r
+[ \ divide [ see ] with-string-writer ] unit-test\r
\r
DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\r
\r
[ 3 ] [ 9 3 divide* ] unit-test\r
-[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
+\r
+[\r
+ T{ descriptive-error f\r
+ { { "num" 3 } { "denom" 0 } }\r
+ T{ division-by-zero f 3 }\r
+ divide*\r
+ }\r
+] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
\r
[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! have-delegates?
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
KEY EC_KEY_get0_public_key dup
[| PUB |
KEY EC_KEY_get0_group :> GROUP
- GROUP EC_GROUP_get_degree bits>bytes 1+ :> LEN
+ GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
LEN <byte-array> :> BIN
GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f
EC_POINT_point2oct ssl-error
LEN *uint SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
- ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
\ No newline at end of file
+ ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
USING: accessors calendar continuations destructors kernel math
-math.order namespaces system threads ui ui.gadgets.worlds ;
+math.order namespaces system threads ui ui.gadgets.worlds
+sequences ;
IN: game-loop
TUPLE: game-loop
<PRIVATE
: redraw ( loop -- )
- [ 1+ ] change-frame-number
+ [ 1 + ] change-frame-number
[ tick-slice ] [ delegate>> ] bi draw* ;
: tick ( loop -- )
delegate>> tick* ;
: increment-tick ( loop -- )
- [ 1+ ] change-tick-number
+ [ 1 + ] change-tick-number
dup tick-length>> [ + ] curry change-last-tick
drop ;
: ?tick ( loop count -- )
- dup zero? [ drop millis >>last-tick drop ] [
+ [ millis >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
+ [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
[ 2drop ] if
- ] if ;
+ ] if-zero ;
: (run-loop) ( loop -- )
dup running?>>
: (mint) ( tuple counter -- tuple )
2dup set-suffix checksummed-bits pick
- valid-guess? [ drop ] [ 1+ (mint) ] if ;
+ valid-guess? [ drop ] [ 1 + (mint) ] if ;
PRIVATE>
: find-nth ( seq quot n -- i elt )
[ <enum> >alist ] 2dip -rot
- '[ _ [ second @ ] find-from rot drop swap 1+ ]
+ '[ _ [ second @ ] find-from rot drop swap 1 + ]
[ f 0 ] 2dip times drop first2 ; inline
: find-first-name ( vector string -- i/f tag/f )
: find-between* ( vector i/f tag/f -- vector )
over integer? [
[ tail-slice ] [ name>> ] bi*
- dupd find-matching-close drop dup [ 1+ ] when
+ dupd find-matching-close drop dup [ 1 + ] when
[ head ] [ first ] if*
] [
3drop V{ } clone
0 [ [ 7 shift ] dip bitor ] reduce ;
: synchsafe>seq ( n -- seq )
- dup 1+ log2 1+ 7 / ceiling
+ dup 1 + log2 1 + 7 / ceiling
[ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
dup 0 > [
[ drop call( host port -- stream ) ]
- [ drop 15 sleep 1- do-connect ]
+ [ drop 15 sleep 1 - do-connect ]
recover
] [ 2drop 2drop f ] if ;
C: <segment> segment
: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
+ [ number>> 1 + ] keep (>>number) ;
: clamp-length ( n seq -- n' )
0 swap length clamp ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- [ dup last random-segment over push ] dip 1- (random-segments)
+ [ dup last random-segment over push ] dip 1 - (random-segments)
] [ drop ] if ;
CONSTANT: default-segment-radius 1
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+ swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
over clamp-length swap nth ;
: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
+ number>> 1 + get-segment ;
: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
+ number>> 1 - get-segment ;
: heading-segment ( segments current-segment heading -- segment )
#! the next segment on the given heading
: inversions ( seq -- n )
0 swap [ length ] keep [
- [ nth ] 2keep swap 1+ tail-slice (inversions) +
+ [ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
: duplicates? ( seq -- ? )
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
+ dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
- [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
+ [ ?nth ] [ [ 1 + ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
] if ;
: graded-triple ( seq n -- triple )
- 3 [ 1- + ] with map swap [ ?nth ] curry map ;
+ 3 [ 1 - + ] with map swap [ ?nth ] curry map ;
: graded-triples ( seq -- triples )
dup length [ graded-triple ] with map ;
! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.constants math.functions
- math.vectors sequences ;
+USING: combinators.short-circuit kernel math math.constants
+math.functions math.vectors sequences ;
IN: math.analysis
<PRIVATE
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
[ [ e / ] keep ^ ]
- [ 12 * recip 1+ ] tri * * ;
+ [ 12 * recip 1 + ] tri * * ;
MACRO: chain-rule ( word -- e )
[ input-length '[ _ duals>nweave ] ]
[ "derivative" word-prop ]
- [ input-length 1+ '[ _ nspread ] ]
+ [ input-length 1 + '[ _ nspread ] ]
tri
'[ [ @ _ @ ] sum-outputs ] ;
! Specialize math functions to operate on dual numbers.
[ all-words [ "derivative" word-prop ] filter
- [ define-dual ] each ] with-compilation-unit
\ No newline at end of file
+ [ define-dual ] each ] with-compilation-unit
<PRIVATE
: weighted ( x y a -- z )
- tuck [ * ] [ 1- neg * ] 2bi* + ;
+ tuck [ * ] [ 1 - neg * ] 2bi* + ;
: a ( n -- a )
- 1+ 2 swap / ;
+ 1 + 2 swap / ;
PRIVATE>
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1 - next-prime [ next-prime ] lfrom-by ] if ;
] if ;
: (number>text) ( n -- str )
- [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
+ [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
PRIVATE>
} cond ;
: over-1000000 ( n -- str )
- 3digit-groups [ 1+ units nth n-units ] map-index sift
+ 3 digit-groups [ 1 + units nth n-units ] map-index sift
reverse " " join ;
: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
USING: help.markup help.syntax ;
IN: math.text.utils
-HELP: 3digit-groups
-{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
-{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;
+HELP: digit-groups
+{ $values { "n" "a positive integer" } { "k" "a positive integer" } { "seq" "a sequence" } }
+{ $description "Decompose a number into groups of " { $snippet "k" } " digits and return them in a sequence starting with the least significant grouped digits first." } ;
USING: math.text.utils tools.test ;
-[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test
+[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel fry math.functions math sequences ;
IN: math.text.utils
-: 3digit-groups ( n -- seq )
- [ dup 0 > ] [ 1000 /mod ] produce nip ;
+: digit-groups ( n k -- seq )
+ [ dup 0 > ] swap '[ _ 10^ /mod ] produce nip ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien destructors help.markup help.syntax kernel math ;
+IN: memory.piles
+
+HELP: <pile>
+{ $values
+ { "size" integer }
+ { "pile" pile }
+}
+{ $description "Allocates " { $snippet "size" } " bytes of raw memory for a new " { $link pile } ". The pile should be " { $link dispose } "d when it is no longer needed." } ;
+
+HELP: not-enough-pile-space
+{ $values
+ { "pile" pile }
+}
+{ $description "This error is thrown by " { $link pile-alloc } " when the " { $link pile } " does not have enough remaining space for the requested allocation." } ;
+
+HELP: pile
+{ $class-description "A " { $snippet "pile" } " is a block of raw memory that can be apportioned out in constant time. A pile is allocated using the " { $link <pile> } " word. Blocks of memory can be requested from the pile using " { $link pile-alloc } ", and all the pile's memory can be reclaimed with " { $link pile-empty } "." } ;
+
+HELP: pile-align
+{ $values
+ { "pile" pile } { "align" "a power of two" }
+ { "pile" pile }
+}
+{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ;
+
+HELP: pile-alloc
+{ $values
+ { "pile" pile } { "size" integer }
+ { "alien" alien }
+}
+{ $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ;
+
+HELP: pile-empty
+{ $values
+ { "pile" pile }
+}
+{ $description "Reclaims all the memory allocated out of a " { $link pile } ". Allocations will resume from the beginning of the pile." } ;
+
+ARTICLE: "memory.piles" "Piles"
+"A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning."
+{ $subsection <pile> }
+{ $subsection pile-alloc }
+{ $subsection pile-align }
+{ $subsection pile-empty }
+"An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ;
+
+ABOUT: "memory.piles"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien destructors kernel math
+memory.piles tools.test ;
+IN: memory.piles.tests
+
+[ 25 ] [
+ [
+ 100 <pile> &dispose
+ [ 25 pile-alloc ] [ 50 pile-alloc ] bi
+ swap [ alien-address ] bi@ -
+ ] with-destructors
+] unit-test
+
+[ 32 ] [
+ [
+ 100 <pile> &dispose
+ [ 25 pile-alloc ] [ 8 pile-align 50 pile-alloc ] bi
+ swap [ alien-address ] bi@ -
+ ] with-destructors
+] unit-test
+
+[ 75 ] [
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 50 pile-alloc drop
+ offset>>
+ ] with-destructors
+] unit-test
+
+[ 100 ] [
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 75 pile-alloc drop
+ offset>>
+ ] with-destructors
+] unit-test
+
+[
+ [
+ 100 <pile> &dispose
+ dup 25 pile-alloc drop
+ dup 76 pile-alloc drop
+ ] with-destructors
+] [ not-enough-pile-space? ] must-fail-with
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien destructors kernel libc math ;
+IN: memory.piles
+
+TUPLE: pile
+ { underlying c-ptr }
+ { size integer }
+ { offset integer } ;
+
+ERROR: not-enough-pile-space pile ;
+
+M: pile dispose
+ [ [ free ] when* f ] change-underlying drop ;
+
+: <pile> ( size -- pile )
+ [ malloc ] keep 0 pile boa ;
+
+: pile-empty ( pile -- )
+ 0 >>offset drop ;
+
+: pile-alloc ( pile size -- alien )
+ [
+ [ [ ] [ size>> ] [ offset>> ] tri ] dip +
+ < [ not-enough-pile-space ] [ drop ] if
+ ] [
+ drop [ offset>> ] [ underlying>> ] bi <displaced-alien>
+ ] [
+ [ + ] curry change-offset drop
+ ] 2tri ;
+
+: pile-align ( pile align -- pile )
+ [ align ] curry change-offset ;
+
--- /dev/null
+Preallocated raw memory blocks
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: classes help.markup help.syntax kernel math ;
+IN: memory.pools
+
+HELP: <pool>
+{ $values
+ { "size" integer } { "class" class }
+ { "pool" pool }
+}
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } "." } ;
+
+HELP: POOL:
+{ $syntax "POOL: class size" }
+{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } ", and associates it with the class using " { $link set-class-pool } "." } ;
+
+HELP: class-pool
+{ $values
+ { "class" class }
+ { "pool" pool }
+}
+{ $description "Returns the " { $link pool } " associated with " { $snippet "class" } ", or " { $link f } " if no pool is associated." } ;
+
+HELP: free-to-pool
+{ $values
+ { "object" object }
+}
+{ $description "Frees an object from the " { $link pool } " it was allocated from. The object must have been allocated by " { $link new-from-pool } "." } ;
+
+HELP: new-from-pool
+{ $values
+ { "class" class }
+ { "object" object }
+}
+{ $description "Allocates an object from the " { $link pool } " associated with " { $snippet "class" } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ POSTPONE: POOL: class-pool set-class-pool new-from-pool free-to-pool } related-words
+
+HELP: pool
+{ $class-description "A " { $snippet "pool" } " contains a fixed-size set of preallocated tuple objects. Once the pool has been allocated, its objects can be allocated with " { $link pool-new } " and freed with " { $link pool-free } " in constant time. A pool can also be associated with its class with the " { $link POSTPONE: POOL: } " syntax or the " { $link set-class-pool } " word, after which the words " { $link new-from-pool } " and " { $link free-to-pool } " can be used with the class name to allocate and free objects." } ;
+
+HELP: pool-free
+{ $values
+ { "object" object } { "pool" pool }
+}
+{ $description "Frees an object back into " { $link pool } "." } ;
+
+HELP: pool-size
+{ $values
+ { "pool" pool }
+ { "size" integer }
+}
+{ $description "Returns the number of unallocated objects inside a " { $link pool } "." } ;
+
+HELP: pool-new
+{ $values
+ { "pool" pool }
+ { "object" object }
+}
+{ $description "Returns an unallocated object out of a " { $link pool } ". If the pool is exhausted, " { $link f } " is returned." } ;
+
+{ pool <pool> pool-new pool-free pool-size } related-words
+
+HELP: set-class-pool
+{ $values
+ { "class" class } { "pool" pool }
+}
+{ $description "Associates a " { $link pool } " with " { $snippet "class" } "." } ;
+
+ARTICLE: "memory.pools" "Pools"
+"The " { $vocab-link "memory.pools" } " vocabulary provides " { $link pool } " objects which manage preallocated collections of objects."
+{ $subsection pool }
+{ $subsection POSTPONE: POOL: }
+{ $subsection new-from-pool }
+{ $subsection free-to-pool } ;
+
+ABOUT: "memory.pools"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel memory.pools tools.test ;
+IN: memory.pools.tests
+
+TUPLE: foo x ;
+
+[ 1 ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool drop
+ foo class-pool pool-size
+] unit-test
+
+[ T{ foo } T{ foo } f ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool
+ foo new-from-pool
+ foo new-from-pool
+] unit-test
+
+[ f ] [
+ foo 2 foo <pool> set-class-pool
+
+ foo new-from-pool
+ foo new-from-pool
+ eq?
+] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays bit-arrays classes
+classes.tuple.private fry kernel locals parser
+sequences sequences.private vectors words ;
+IN: memory.pools
+
+TUPLE: pool
+ prototype
+ { objects vector } ;
+
+: <pool> ( size class -- pool )
+ [ nip new ]
+ [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
+ pool boa ;
+
+: pool-size ( pool -- size )
+ objects>> length ;
+
+<PRIVATE
+
+:: copy-tuple ( from to -- to )
+ from tuple-size :> size
+ size [| n | n from array-nth n to set-array-nth ] each
+ to ; inline
+
+: (pool-new) ( pool -- object )
+ objects>> [ f ] [ pop ] if-empty ;
+
+: (pool-init) ( pool object -- object )
+ [ prototype>> ] dip copy-tuple ; inline
+
+PRIVATE>
+
+: pool-new ( pool -- object )
+ dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline
+
+: pool-free ( object pool -- )
+ objects>> push ;
+
+: class-pool ( class -- pool )
+ "pool" word-prop ;
+
+: set-class-pool ( class pool -- )
+ "pool" set-word-prop ;
+
+: new-from-pool ( class -- object )
+ class-pool pool-new ;
+
+: free-to-pool ( object -- )
+ dup class class-pool pool-free ;
+
+SYNTAX: POOL:
+ scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;
+
--- /dev/null
+Preallocated pools of tuple objects
] unit-test
LAZY: nats-from ( n -- list )
- dup 1+ nats-from cons ;
+ dup 1 + nats-from cons ;
: nats ( -- list ) 0 nats-from ;
[
[ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
] keep length
- 10 swap ^ / + swap [ neg ] when ;
+ 10^ / + swap [ neg ] when ;
SYNTAX: DECIMAL: scan parse-decimal parsed ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets see effects.parser ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length <reversed> [ 1 + neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> dup <enum> ] dip update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry filter empty?
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+IN: multi-methods.tests
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+<< (( -- )) \ fake set-stack-effect >>
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing (( -- )) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+USING: math strings sequences tools.test ;
+IN: multi-methods.tests
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
+IN: multi-methods.tests
+
+multi-methods:GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } 2drop t ;
+METHOD: beats? { scissors rock } 2drop t ;
+METHOD: beats? { rock paper } 2drop t ;
+METHOD: beats? { thing thing } 2drop f ;
+
+: play ( obj1 obj2 -- ? ) beats? ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+multi-methods:GENERIC: hook-test ( obj -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
2drop epsilon
] [
2dup exactly-n
- -rot 1- at-most-n <|>
+ -rot 1 - at-most-n <|>
] if ;
: at-least-n ( parser n -- parser' )
:: prepare-pos ( v i -- c l )
[let | n [ i v head-slice ] |
- v CHAR: \n n last-index -1 or 1+ -
- n [ CHAR: \n = ] count 1+
+ v CHAR: \n n last-index -1 or 1 + -
+ n [ CHAR: \n = ] count 1 +
] ;
: store-pos ( v a -- )
[ swap hash>> set-at ]
} case ;
-:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ;
+:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ;
M: lex-hash at*
swap {
{ input [ drop lexer get text>> "\n" join t ] }
- { pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] }
+ { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
[ swap hash>> at* ]
} case ;
spaces = space* => [[ drop ignore ]]
chunk = (!(space) .)+ => [[ >string ]]
expr = spaces chunk
-;EBNF
\ No newline at end of file
+;EBNF
--- /dev/null
+USING: help help.markup help.syntax kernel quotations ;
+IN: prettyprint.callables
+
+HELP: simplify-callable
+{ $values { "quot" callable } { "quot'" callable } }
+{ $description "Converts " { $snippet "quot" } " into an equivalent quotation by simplifying usages of " { $link dip } ", " { $link call } ", " { $link curry } ", and " { $link compose } " with literal parameters. This word is used when callable objects are prettyprinted." } ;
--- /dev/null
+! (c) 2009 Joe Groff bsd license
+USING: kernel math prettyprint prettyprint.callables
+tools.test ;
+IN: prettyprint.callables.tests
+
+[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test
+[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test
+[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test
+[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test
+[ [ call ] ] [ [ call ] simplify-callable ] unit-test
+[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test
+[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test
+[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test
+[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test
+[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test
--- /dev/null
+! (c) 2009 Joe Groff bsd license
+USING: combinators combinators.short-circuit generalizations
+kernel macros math math.ranges prettyprint.custom quotations
+sequences words ;
+IN: prettyprint.callables
+
+<PRIVATE
+
+CONSTANT: simple-combinators { dip call curry 2curry 3curry compose prepose }
+
+: literal? ( obj -- ? ) word? not ;
+
+MACRO: slice-match? ( quots -- quot: ( seq end -- ? ) )
+ dup length
+ [ 0 [a,b) [ [ - swap nth ] swap prefix prepend ] 2map ]
+ [ nip \ nip swap \ >= [ ] 3sequence ] 2bi
+ prefix \ 2&& [ ] 2sequence ;
+
+: end-len>from-to ( seq end len -- from to seq )
+ [ - ] [ drop 1 + ] 2bi rot ;
+
+: slice-change ( seq end len quot -- seq' )
+ [ end-len>from-to ] dip
+ [ [ subseq ] dip call ] curry
+ [ replace-slice ] 3bi ; inline
+
+: when-slice-match ( seq i criteria quot -- seq' )
+ [ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline
+
+: simplify-dip ( quot i -- quot' )
+ { [ literal? ] [ callable? ] }
+ [ 2 [ first2 swap suffix ] slice-change ] when-slice-match ;
+
+: simplify-call ( quot i -- quot' )
+ { [ callable? ] }
+ [ 1 [ first ] slice-change ] when-slice-match ;
+
+: simplify-curry ( quot i -- quot' )
+ { [ literal? ] [ callable? ] }
+ [ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-2curry ( quot i -- quot' )
+ { [ literal? ] [ literal? ] [ callable? ] }
+ [ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-3curry ( quot i -- quot' )
+ { [ literal? ] [ literal? ] [ literal? ] [ callable? ] }
+ [ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-compose ( quot i -- quot' )
+ { [ callable? ] [ callable? ] }
+ [ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-prepose ( quot i -- quot' )
+ { [ callable? ] [ callable? ] }
+ [ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ;
+
+: (simplify-callable) ( quot -- quot' )
+ dup [ simple-combinators member? ] find {
+ { \ dip [ simplify-dip ] }
+ { \ call [ simplify-call ] }
+ { \ curry [ simplify-curry ] }
+ { \ 2curry [ simplify-2curry ] }
+ { \ 3curry [ simplify-3curry ] }
+ { \ compose [ simplify-compose ] }
+ { \ prepose [ simplify-prepose ] }
+ [ 2drop ]
+ } case ;
+
+PRIVATE>
+
+: simplify-callable ( quot -- quot' )
+ [ (simplify-callable) ] to-fixed-point ;
+
+M: callable >pprint-sequence simplify-callable ;
--- /dev/null
+Quotation simplification for prettyprinting automatically-constructed callable objects
<PRIVATE
: sum-divisible-by ( target n -- m )
- [ /i dup 1+ * ] keep * 2 /i ;
+ [ /i dup 1 + * ] keep * 2 /i ;
PRIVATE>
! --------
: euler012 ( -- answer )
- 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ;
+ 8 [ dup nth-triangle tau* 500 < ] [ 1 + ] while nth-triangle ;
! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials)
<PRIVATE
: next-collatz ( n -- n )
- dup even? [ 2 / ] [ 3 * 1+ ] if ;
+ dup even? [ 2 / ] [ 3 * 1 + ] if ;
: longest ( seq seq -- seq )
2dup [ length ] bi@ > [ drop ] [ nip ] if ;
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ divisor? ] [ / even? ] } 2&& ;
+ 1 - 3 { [ divisor? ] [ / even? ] } 2&& ;
PRIVATE>
ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq )
- [ 1+ swap alpha-value * ] map-index ;
+ [ 1 + swap alpha-value * ] map-index ;
PRIVATE>
<PRIVATE
: (digit-fib) ( n term -- term )
- 2dup fib number>string length > [ 1+ (digit-fib) ] [ nip ] if ;
+ 2dup fib number>string length > [ 1 + (digit-fib) ] [ nip ] if ;
: digit-fib ( n -- term )
1 (digit-fib) ;
<PRIVATE
: digit-fib* ( n -- term )
- 1- 5 log10 2 / + phi log10 / ceiling >integer ;
+ 1 - 5 log10 2 / + phi log10 / ceiling >integer ;
PRIVATE>
1 1000 (a,b) [ prime? ] filter [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
- 3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
+ 3dup ^ swap mod 1 = [ 2nip ] [ 1 + (mult-order) ] if ;
PRIVATE>
dup sq -rot * + + ;
: (consecutive-primes) ( b a n -- m )
- 3dup quadratic prime? [ 1+ (consecutive-primes) ] [ 2nip ] if ;
+ 3dup quadratic prime? [ 1 + (consecutive-primes) ] [ 2nip ] if ;
: consecutive-primes ( a b -- m )
swap 0 (consecutive-primes) ;
PRIVATE>
: euler030 ( -- answer )
- 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: (circular?) ( seq n -- ? )
dup 0 > [
2dup rotate 10 digits>integer
- prime? [ 1- (circular?) ] [ 2drop f ] if
+ prime? [ 1 - (circular?) ] [ 2drop f ] if
] [
2drop t
] if ;
: circular? ( seq -- ? )
- dup length 1- (circular?) ;
+ dup length 1 - (circular?) ;
PRIVATE>
pick length 8 > [
2drop 10 digits>integer
] [
- [ * number>digits over push-all ] 2keep 1+ (concat-product)
+ [ * number>digits over push-all ] 2keep 1 + (concat-product)
] if ;
: concat-product ( n -- m )
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
: (concat-upto) ( n limit str -- str )
2dup length > [
- pick number>string over push-all rot 1+ -rot (concat-upto)
+ pick number>string over push-all rot 1 + -rot (concat-upto)
] [
2nip
] if ;
SBUF" " clone 1 -rot (concat-upto) ;
: nth-integer ( n str -- m )
- [ 1- ] dip nth 1string string>number ;
+ [ 1 - ] dip nth 1string string>number ;
PRIVATE>
: (triangle-upto) ( limit n -- )
2dup nth-triangle > [
- dup nth-triangle , 1+ (triangle-upto)
+ dup nth-triangle , 1 + (triangle-upto)
] [
2drop
] if ;
<PRIVATE
: triangle? ( n -- ? )
- 8 * 1+ sqrt 1- 2 / 1 mod zero? ;
+ 8 * 1 + sqrt 1 - 2 / 1 mod zero? ;
PRIVATE>
<PRIVATE
: subseq-divisible? ( n index seq -- ? )
- [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
+ [ 1 - dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
: interesting? ( seq -- ? )
{
<PRIVATE
: nth-pentagonal ( n -- seq )
- dup 3 * 1- * 2 / ;
+ dup 3 * 1 - * 2 / ;
: sum-and-diff? ( m n -- ? )
[ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
<PRIVATE
: nth-hexagonal ( n -- m )
- dup 2 * 1- * ;
+ dup 2 * 1 - * ;
DEFER: next-solution
dup pentagonal? [ nip ] [ drop next-solution ] if ;
: next-solution ( n -- m )
- 1+ dup nth-hexagonal (next-solution) ;
+ 1 + dup nth-hexagonal (next-solution) ;
PRIVATE>
dup perfect-squares [ 2 * - ] with map [ prime? ] any? ;
: next-odd-composite ( n -- m )
- dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
+ dup odd? [ 2 + ] [ 1 + ] if dup prime? [ next-odd-composite ] when ;
: disprove-conjecture ( n -- m )
dup fits-conjecture? [ next-odd-composite disprove-conjecture ] when ;
swap - nip
] [
dup prime? [ [ drop 0 ] 2dip ] [
- 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if
- ] if 1+ (consecutive)
+ 2dup unique-factors length = [ [ 1 + ] 2dip ] [ [ drop 0 ] 2dip ] if
+ ] if 1 + (consecutive)
] if ;
: consecutive ( goal test -- n )
sieve get nth 0 = ;
: multiples ( n -- seq )
- sieve get length 1- over <range> ;
+ sieve get length 1 - over <range> ;
: increment-counts ( n -- )
- multiples [ sieve get [ 1+ ] change-nth ] each ;
+ multiples [ sieve get [ 1 + ] change-nth ] each ;
: prime-tau-upto ( limit -- seq )
dup initialize-sieve 2 swap [a,b) [
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges project-euler.common sequences ;
+USING: kernel math math.functions math.ranges
+project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
! --------
: euler048 ( -- answer )
- 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
+ 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
: count-digits ( n -- byte-array )
10 <byte-array> [
- '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+ '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
] keep ;
HINTS: count-digits fixnum ;
2dup [ first ] bi@ > [ drop ] [ nip ] if ;
: continue? ( pair seq -- ? )
- [ first ] [ length 1- ] bi* < ;
+ [ first ] [ length 1 - ] bi* < ;
: (find-longest) ( best seq limit -- best )
[ longest-prime longest ] 2keep 2over continue? [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1+ * ] with map ; inline
+ [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
: next-all-same ( x n -- n )
dup candidate? [
2dup swap map-nx all-same-digits?
- [ nip ] [ 1+ next-all-same ] if
+ [ nip ] [ 1 + next-all-same ] if
] [
- 1+ next-all-same
+ 1 + next-all-same
] if ;
PRIVATE>
: (lychrel?) ( n iteration -- ? )
dup 50 < [
[ add-reverse ] dip over palindrome?
- [ 2drop f ] [ 1+ (lychrel?) ] if
+ [ 2drop f ] [ 1 + (lychrel?) ] if
] [
2drop t
] if ;
! (n-2)² + 4(n-1) = odd squares, no need to calculate
: prime-corners ( n -- m )
- 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
+ 3 [1,b] swap '[ _ [ 1 - * ] keep 2 - sq + prime? ] count ;
: total-corners ( n -- m )
- 1- 2 * ; foldable
+ 1 - 2 * ; foldable
: ratio-below? ( count length -- ? )
- total-corners 1+ / PERCENT_PRIME < ;
+ total-corners 1 + / PERCENT_PRIME < ;
: next-layer ( count length -- count' length' )
2 + [ prime-corners + ] keep ;
} cond product ;
: primorial-upto ( limit -- m )
- 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ 1 swap '[ dup primorial _ <= ] [ 1 + dup primorial ] produce
nip penultimate ;
PRIVATE>
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
over zero? [
3drop
] [
- [ [ 1- 2array ] dip at ]
+ [ [ 1 - 2array ] dip at ]
[ [ use 2array ] dip at + ]
[ [ 2array ] dip set-at ] 3tri
] if ;
: (euler076) ( n -- m )
dup init
[ [ ways ] curry each-subproblem ]
- [ [ dup 2array ] dip at 1- ] 2bi ;
+ [ [ dup 2array ] dip at 1 - ] 2bi ;
PRIVATE>
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
- dup 567 > [ next-link ] when 1- swap nth ;
+ dup 567 > [ next-link ] when 1 - swap nth ;
PRIVATE>
! --------
: euler097 ( -- answer )
- 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
+ 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1 + ;
! [ euler097 ] 100 ave-time
! 0 ms ave run timen - 0.22 SD (100 trials)
flip first2 swap [ log ] map v* ;
: solve ( seq -- index )
- simplify [ supremum ] keep index 1+ ;
+ simplify [ supremum ] keep index 1 + ;
PRIVATE>
: euler100 ( -- answer )
1 1
- [ dup dup 1- * 2 * 10 24 ^ <= ]
+ [ dup dup 1 - * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] while nip ;
! TODO: solution needs generalization
<PRIVATE
: nth* ( n seq -- elt/0 )
- [ length swap - 1- ] keep ?nth 0 or ;
+ [ length swap - 1 - ] keep ?nth 0 or ;
: next ( colortile seq -- )
[ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
- V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ;
+ V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
<PRIVATE
: sum-1toN ( n -- sum )
- dup 1+ * 2/ ; inline
+ dup 1 + * 2/ ; inline
: >base7 ( x -- y )
[ dup 0 > ] [ 7 /mod ] produce nip ;
: (use-digit) ( prev x index -- next )
- [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
+ [ [ 1 + * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
: (euler148) ( x -- y )
>base7 0 [ (use-digit) ] reduce-index ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
- x 1+ [| y |
+ x 1 + [| y |
m x - [0,b) [| z |
x z + table nth-unsafe
- [ y z + 1+ swap nth-unsafe ]
+ [ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
] map partial-sum-infimum
] map-infimum
--- /dev/null
+USING: project-euler.151 tools.test ;
+IN: project-euler.151.tests
+
+[ 12138569781349/26138246400000 ] [ euler151 ] unit-test
: (pick-sheet) ( seq i -- newseq )
[
- <=> sgn
+ <=>
{
- { -1 [ ] }
- { 0 [ 1- ] }
- { 1 [ 1+ ] }
+ { +lt+ [ ] }
+ { +eq+ [ 1 - ] }
+ { +gt+ [ 1 + ] }
} case
] curry map-index ;
: (euler151) ( x -- y )
table get [ {
{ { 0 0 0 1 } [ 0 ] }
- { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
- { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
- { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+ { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
+ { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
+ { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
[ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
{ 1 1 1 1 } (euler151)
] with-scope ;
-! TODO: doesn't work currently, problem in area of 'with map' in (euler151)
-
! [ euler151 ] 100 ave-time
! ? ms run time - 100 trials
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- [ 2/ [ fn ] [ 1- fn ] bi + ]
+ [ 2/ [ fn ] [ 1 - fn ] bi + ]
} cond ;
: euler169 ( -- result )
: compute ( vec ratio -- )
{
- { [ dup integer? ] [ 1- 0 add-bits ] }
+ { [ dup integer? ] [ 1 - 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
[ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
pick [ next ] [ next ] bi
[ = ] [
pick equate
- [ 1+ ] dip
+ [ 1 + ] dip
] 2unless? (p186)
] [
drop nip
PRIVATE>
:: P_m ( m -- P_m )
- m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+ m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
: euler190 ( -- answer )
2 15 [a,b] [ P_m truncate ] sigma ;
[ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
: generate ( n -- seq )
- 1- { 1 } [ (generate) ] iterate concat prune ;
+ 1 - { 1 } [ (generate) ] iterate concat prune ;
: squarefree ( n -- ? )
factors all-unique? ;
: first-row ( n -- t )
[ <failure> <success> <failure> ] dip
- 1- [| a b c | b c <block> a b ] times 2drop ;
+ 1 - [| a b c | b c <block> a b ] times 2drop ;
GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end total ways>> ;
: solve ( width height -- ways )
- [ first-row ] dip 1- [ next-row ] times total ;
+ [ first-row ] dip 1 - [ next-row ] times total ;
PRIVATE>
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations fry io kernel make math math.functions math.parser
- math.statistics memory tools.time ;
+USING: continuations fry io kernel make math math.functions
+math.parser math.statistics memory tools.time ;
IN: project-euler.ave-time
: nth-place ( x n -- y )
- 10 swap ^ [ * round >integer ] keep /f ;
+ 10^ [ * round >integer ] keep /f ;
: collect-benchmarks ( quot n -- seq )
[
'[ _ gc benchmark 1000 / , ] tuck
'[ _ _ with-datastack drop ]
]
- [ 1- ] tri* swap times call
+ [ 1 - ] tri* swap times call
] { } make ; inline
: ave-time ( quot n -- )
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1- [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
PRIVATE>
: alpha-value ( str -- n )
- >lower [ CHAR: a - 1+ ] sigma ;
+ >lower [ CHAR: a - 1 + ] sigma ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;
-: log10 ( m -- n )
- log 10 log / ;
-
: mediant ( a/c b/d -- (a+b)/(c+d) )
2>fraction [ + ] 2bi@ / ;
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m )
- log10 floor 1+ >integer ;
+ log10 floor 1 + >integer ;
: nth-prime ( n -- n )
- 1- lprimes lnth ;
+ 1 - lprimes lnth ;
: nth-triangle ( n -- n )
- dup 1+ * 2 / ;
+ dup 1 + * 2 / ;
: palindrome? ( n -- ? )
number>string dup reverse = ;
number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
- dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+ dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! The divisor function, counts the number of divisors
: tau ( m -- n )
- group-factors flip second 1 [ 1+ * ] reduce ;
+ group-factors flip second 1 [ 1 + * ] reduce ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
- factor-2s dup [ 1+ ]
+ factor-2s dup [ 1 + ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
dupd divisor? [ [ 2 + ] dip ] when
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel lists math math.parser
+sequences splitting ;
+IN: rpn
+
+SINGLETONS: add-insn sub-insn mul-insn div-insn ;
+TUPLE: push-insn value ;
+
+GENERIC: eval-insn ( stack insn -- stack )
+
+: binary-op ( stack quot: ( x y -- z ) -- stack )
+ [ uncons uncons ] dip dip cons ; inline
+
+M: add-insn eval-insn drop [ + ] binary-op ;
+M: sub-insn eval-insn drop [ - ] binary-op ;
+M: mul-insn eval-insn drop [ * ] binary-op ;
+M: div-insn eval-insn drop [ / ] binary-op ;
+M: push-insn eval-insn value>> swons ;
+
+: rpn-tokenize ( string -- string' )
+ " " split harvest sequence>list ;
+
+: rpn-parse ( string -- tokens )
+ rpn-tokenize [
+ {
+ { "+" [ add-insn ] }
+ { "-" [ sub-insn ] }
+ { "*" [ mul-insn ] }
+ { "/" [ div-insn ] }
+ [ string>number push-insn boa ]
+ } case
+ ] lmap ;
+
+: print-stack ( list -- )
+ [ number>string print ] leach ;
+
+: rpn-eval ( tokens -- )
+ nil [ eval-insn ] foldl print-stack ;
+
+: rpn ( -- )
+ "RPN> " write flush
+ readln [ rpn-parse rpn-eval rpn ] when* ;
+
+MAIN: rpn
--- /dev/null
+Simple RPN calculator
] take-until :> found
growing sequence sequence= [
found dup length
- growing length 1- - head
+ growing length 1 - - head
sequence-parser [ growing length - 1 + ] change-n drop
! sequence-parser advance drop
] [
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
:: (carry-n) ( ns lengths i -- )
- ns length i 1+ = [
+ ns length i 1 + = [
i ns nth i lengths nth = [
0 i ns set-nth
- i 1+ ns [ 1+ ] change-nth
- ns lengths i 1+ (carry-n)
+ i 1 + ns [ 1 + ] change-nth
+ ns lengths i 1 + (carry-n)
] when
] unless ;
0 (carry-n) ;
: product-iter ( ns lengths -- )
- [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+ [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
: start-product-iter ( sequence-product -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
0 :> i!
sequences [ length ] [ * ] map-reduce sequences
[| result |
- sequences [ quot call i result set-nth i 1+ i! ] product-each
+ sequences [ quot call i result set-nth i 1 + i! ] product-each
result
] new-like ; inline
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1- [
+ dup third length 1 - [
2 + (strip-tease)
] with map ;
[ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
- [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
+ [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
make-return ;
: compile-method ( lexenv ast-method -- )
: compile-smalltalk ( statement -- quot )
[ empty-lexenv ] dip [ compile-sequence nip 0 ]
- 2keep make-return ;
\ No newline at end of file
+ 2keep make-return ;
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
- [ [ 1+ ] change-count ] dip
+ [ [ 1 + ] change-count ] dip
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
[ filter-base-links ] 2keep
- depth>> 1+ swap
+ depth>> 1 + swap
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
DEFER: search
: assume ( n x y -- )
- [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
+ [ >board ] 2keep [ [ 1 + ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
: board. ( board -- )
standard-table-style [
: search ( x y -- )
{
- { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
+ { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
- { [ 2dup board> ] [ [ 1+ ] dip search ] }
+ { [ 2dup board> ] [ [ 1 + ] dip search ] }
[ solve ]
} cond ;
: svg-string>number ( string -- number )
{ { CHAR: E CHAR: e } } substitute "e" split1
- [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* *
+ [ string>number ] [ [ string>number 10^ ] [ 1 ] if* ] bi* *
>float ;
: degrees ( deg -- rad ) pi * 180.0 / ;
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1+
+ MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
GetComputerName win32-error=0/f alien>native-string ;
destructors grid-meshes ;
IN: terrain
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
[ not ] change-paused? drop ;
: level>> ( tetris -- level )
- rows>> 1+ 10 / ceiling ;
+ rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1- 60 * 1000 swap - ;
+ level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
over board>> spin current-piece tetromino>> colour>> set-block ;
{ 2 [ 100 ] }
{ 3 [ 300 ] }
{ 4 [ 1200 ] }
- } case swap 1+ * ;
+ } case swap 1 + * ;
: add-score ( tetris n-rows -- tetris )
over level>> swap rows-score swap [ + ] change-score ;
tetrominoes get random ;
: blocks-max ( blocks quot -- max )
- map [ 1+ ] [ max ] map-reduce ; inline
+ map [ 1 + ] [ max ] map-reduce ; inline
: blocks-width ( blocks -- width )
[ first ] blocks-max ;
: go-left? ( -- ? ) current-side get left eq? ;
-: inc-count ( tree -- ) [ 1+ ] change-count drop ;
+: inc-count ( tree -- ) [ 1 + ] change-count drop ;
-: dec-count ( tree -- ) [ 1- ] change-count drop ;
+: dec-count ( tree -- ) [ 1 - ] change-count drop ;
: node-link@ ( node ? -- node )
go-left? xor [ left>> ] [ right>> ] if ;
list-theme ;
: calc-bounded-index ( n list -- m )
- control-value length 1- min 0 max ;
+ control-value length 1 - min 0 max ;
: bound-index ( list -- )
dup index>> over calc-bounded-index >>index drop ;
] if ;
: select-previous ( list -- )
- [ index>> 1- ] keep select-index ;
+ [ index>> 1 - ] keep select-index ;
: select-next ( list -- )
- [ index>> 1+ ] keep select-index ;
+ [ index>> 1 + ] keep select-index ;
: invoke-value-action ( list -- )
dup list-empty? [
*wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
: update-times ( utime current-utime current-numinvokes -- utime' invokes' )
- rot [ + ] curry [ 1+ ] bi* ;
+ rot [ + ] curry [ 1 + ] bi* ;
: register-time ( utime word -- )
name>>
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
-syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
+syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length <reversed> [ 1+ neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry filter empty?
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
-
-: multi-predicate ( classes -- quot )
- dup length <reversed>
- [ picker 2array ] 2map
- [ drop object eq? not ] assoc-filter
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" set
- "multi-method-specializer" set
- ] H{ } make-assoc ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-word ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
-
-[ t ] [ { } \ fake <method> method-body? ] unit-test
-
-[
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing (( -- )) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-IN: multi-methods.tests
-USING: math strings sequences tools.test ;
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-
-GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-GENERIC: hook-test ( -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
projects / factor.git / commitdiff