Merge branch 'master' of git://factorcode.org/git/factor into tangle
Alex Chapman
commit
49bc76eace
|
|
@ -349,7 +349,7 @@ M: curry '
|
|||
[
|
||||
{
|
||||
dictionary source-files
|
||||
typemap builtins class<map update-map
|
||||
typemap builtins class<map class-map update-map
|
||||
} [ dup get swap bootstrap-word set ] each
|
||||
] H{ } make-assoc
|
||||
bootstrap-global set
|
||||
|
|
|
|||
|
|
@ -91,8 +91,9 @@ call
|
|||
} [ create-vocab drop ] each
|
||||
|
||||
H{ } clone source-files set
|
||||
H{ } clone class<map set
|
||||
H{ } clone update-map set
|
||||
H{ } clone class<map set
|
||||
H{ } clone class-map set
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
|
|
@ -547,7 +548,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "eq?" "kernel" }
|
||||
{ "getenv" "kernel.private" }
|
||||
{ "setenv" "kernel.private" }
|
||||
{ "(stat)" "io.files.private" }
|
||||
{ "(exists?)" "io.files.private" }
|
||||
{ "(directory)" "io.files.private" }
|
||||
{ "data-gc" "memory" }
|
||||
{ "code-gc" "memory" }
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ millis >r
|
|||
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"math help handbook compiler random tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
parse-command-line
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ IN: bootstrap.syntax
|
|||
"C:"
|
||||
"CHAR:"
|
||||
"DEFER:"
|
||||
"ERROR:"
|
||||
"F{"
|
||||
"FV{"
|
||||
"FORGET:"
|
||||
|
|
|
|||
|
|
@ -22,6 +22,8 @@ H{ } "s" set
|
|||
[ number ] [ number object class-and ] unit-test
|
||||
[ number ] [ object number class-and ] unit-test
|
||||
[ null ] [ slice reversed class-and ] unit-test
|
||||
[ null ] [ general-t \ f class-and ] unit-test
|
||||
[ object ] [ general-t \ f class-or ] unit-test
|
||||
|
||||
TUPLE: first-one ;
|
||||
TUPLE: second-one ;
|
||||
|
|
|
|||
|
|
@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ;
|
|||
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
|
||||
|
||||
SYMBOL: typemap
|
||||
SYMBOL: class-map
|
||||
SYMBOL: class<map
|
||||
SYMBOL: update-map
|
||||
SYMBOL: builtins
|
||||
|
||||
PREDICATE: word builtin-class
|
||||
PREDICATE: class builtin-class
|
||||
"metaclass" word-prop builtin-class eq? ;
|
||||
|
||||
PREDICATE: class tuple-class
|
||||
|
|
@ -58,6 +59,7 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
|
|||
{ [ dup builtin-class? ] [ dup set ] }
|
||||
{ [ dup members ] [ members [ (flatten-class) ] each ] }
|
||||
{ [ dup superclass ] [ superclass (flatten-class) ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: flatten-class ( class -- assoc )
|
||||
|
|
@ -108,11 +110,31 @@ DEFER: (class<)
|
|||
: lookup-union ( classes -- class )
|
||||
typemap get at dup empty? [ drop object ] [ first ] if ;
|
||||
|
||||
: lookup-tuple-union ( classes -- class )
|
||||
class-map get at dup empty? [ drop object ] [ first ] if ;
|
||||
|
||||
! : (class-or) ( class class -- class )
|
||||
! [ flatten-builtin-class ] 2apply union lookup-union ;
|
||||
!
|
||||
! : (class-and) ( class class -- class )
|
||||
! [ flatten-builtin-class ] 2apply intersect lookup-union ;
|
||||
|
||||
: class-or-fixup ( set set -- set )
|
||||
union
|
||||
tuple over key?
|
||||
[ [ drop tuple-class? not ] assoc-subset ] when ;
|
||||
|
||||
: (class-or) ( class class -- class )
|
||||
[ flatten-builtin-class ] 2apply union lookup-union ;
|
||||
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
|
||||
|
||||
: (class-and) ( class class -- class )
|
||||
[ flatten-builtin-class ] 2apply intersect lookup-union ;
|
||||
2dup [ tuple swap class< ] either? [
|
||||
[ flatten-builtin-class ] 2apply
|
||||
intersect lookup-union
|
||||
] [
|
||||
[ flatten-class ] 2apply
|
||||
intersect lookup-tuple-union
|
||||
] if ;
|
||||
|
||||
: tuple-class-and ( class1 class2 -- class )
|
||||
dupd eq? [ drop null ] unless ;
|
||||
|
|
@ -219,9 +241,16 @@ M: word reset-class drop ;
|
|||
: typemap- ( class -- )
|
||||
dup flatten-builtin-class typemap get pop-at ;
|
||||
|
||||
! class-map
|
||||
: class-map+ ( class -- )
|
||||
dup flatten-class class-map get push-at ;
|
||||
|
||||
: class-map- ( class -- )
|
||||
dup flatten-class class-map get pop-at ;
|
||||
|
||||
! Class definition
|
||||
: cache-class ( class -- )
|
||||
dup typemap+ dup class<map+ update-map+ ;
|
||||
dup typemap+ dup class-map+ dup class<map+ update-map+ ;
|
||||
|
||||
: cache-classes ( assoc -- )
|
||||
[ drop cache-class ] assoc-each ;
|
||||
|
|
@ -229,7 +258,7 @@ M: word reset-class drop ;
|
|||
GENERIC: uncache-class ( class -- )
|
||||
|
||||
M: class uncache-class
|
||||
dup update-map- dup class<map- typemap- ;
|
||||
dup update-map- dup class<map- dup class-map- typemap- ;
|
||||
|
||||
M: word uncache-class drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -261,7 +261,7 @@ cell 8 = [
|
|||
: compiled-fixnum* fixnum* ;
|
||||
|
||||
: test-fixnum*
|
||||
(random) >fixnum (random) >fixnum
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
[ 2drop ] [ "Oops" throw ] if ;
|
||||
|
|
@ -271,7 +271,7 @@ cell 8 = [
|
|||
: compiled-fixnum>bignum fixnum>bignum ;
|
||||
|
||||
: test-fixnum>bignum
|
||||
(random) >fixnum
|
||||
32 random-bits >fixnum
|
||||
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
|
|
@ -280,7 +280,7 @@ cell 8 = [
|
|||
: compiled-bignum>fixnum bignum>fixnum ;
|
||||
|
||||
: test-bignum>fixnum
|
||||
5 random [ drop (random) ] map product >bignum
|
||||
5 random [ drop 32 random-bits ] map product >bignum
|
||||
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: heaps.tests
|
|||
: random-alist ( n -- alist )
|
||||
[
|
||||
[
|
||||
(random) dup number>string swap set
|
||||
32 random-bits dup number>string swap set
|
||||
] times
|
||||
] H{ } make-assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -354,7 +354,7 @@ M: object infer-call
|
|||
|
||||
\ setenv { object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ (stat) { string } { object object object object } <effect> set-primitive-effect
|
||||
\ exists? { string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ (directory) { string } { array } <effect> set-primitive-effect
|
||||
|
||||
|
|
|
|||
|
|
@ -54,9 +54,7 @@ ARTICLE: "fs-meta" "File meta-data"
|
|||
{ $subsection file-info }
|
||||
{ $subsection link-info }
|
||||
{ $subsection exists? }
|
||||
{ $subsection directory? }
|
||||
! { $subsection file-modified }
|
||||
{ $subsection stat } ;
|
||||
{ $subsection directory? } ;
|
||||
|
||||
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
||||
"Operations for deleting and copying files come in two forms:"
|
||||
|
|
@ -216,14 +214,6 @@ HELP: with-directory
|
|||
{ $description "Changes the current working directory for the duration of a quotation's execution." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
||||
HELP: stat ( path -- directory? permissions length modified )
|
||||
{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
|
||||
{ $description
|
||||
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
|
||||
} ;
|
||||
|
||||
{ stat exists? directory? } related-words
|
||||
|
||||
HELP: append-path
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
{ $description "Concatenates two pathnames." } ;
|
||||
|
|
@ -273,7 +263,7 @@ HELP: normalize-directory
|
|||
|
||||
HELP: normalize-pathname
|
||||
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
||||
{ $description "Called by the " { $link stat } " word, and possibly " { $link <file-reader> } " and " { $link <file-writer> } ", to prepare a pathname before passing it to underlying code." } ;
|
||||
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
|
||||
|
||||
HELP: <pathname> ( str -- pathname )
|
||||
{ $values { "str" "a pathname string" } { "pathname" pathname } }
|
||||
|
|
|
|||
|
|
@ -86,14 +86,11 @@ SYMBOL: +socket+
|
|||
SYMBOL: +unknown+
|
||||
|
||||
! File metadata
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
: exists? ( path -- ? )
|
||||
normalize-pathname (exists?) ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
|
||||
: directory? ( path -- ? )
|
||||
file-info file-info-type +directory+ = ;
|
||||
|
||||
! Current working directory
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
USING: vocabs.loader sequences system ;
|
||||
USING: vocabs.loader sequences system
|
||||
random random.mersenne-twister combinators init
|
||||
namespaces ;
|
||||
|
||||
"random.mersenne-twister" require
|
||||
|
||||
|
|
@ -6,3 +8,6 @@ USING: vocabs.loader sequences system ;
|
|||
{ [ windows? ] [ "random.windows" require ] }
|
||||
{ [ unix? ] [ "random.unix" require ] }
|
||||
} cond
|
||||
|
||||
[ millis <mersenne-twister> random-generator set-global ]
|
||||
"generator.random" add-init-hook
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ IN: builder
|
|||
+closed+ >>stdin
|
||||
"../test-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
45 minutes >>timeout ;
|
||||
120 minutes >>timeout ;
|
||||
|
||||
: do-builder-test ( -- )
|
||||
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ USING: alien alien.syntax combinators system ;
|
|||
IN: cairo.ffi
|
||||
|
||||
<< "cairo" {
|
||||
{ [ win32? ] [ "cairo.dll" ] }
|
||||
{ [ win32? ] [ "libcairo-2.dll" ] }
|
||||
! { [ macosx? ] [ "libcairo.dylib" ] }
|
||||
{ [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
|
||||
{ [ unix? ] [ "libcairo.so.2" ] }
|
||||
|
|
|
|||
|
|
@ -59,31 +59,29 @@ SYMBOL: m
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: julian-day-number ( year month day -- n )
|
||||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
[
|
||||
14 pick - 12 /i a set
|
||||
pick 4800 + a get - y set
|
||||
over 12 a get * + 3 - m set
|
||||
2nip 153 m get * 2 + 5 /i + 365 y get * +
|
||||
y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
|
||||
] with-scope ;
|
||||
[let* | a [ 14 month - 12 /i ]
|
||||
y [ year 4800 + a - ]
|
||||
m [ month 12 a * + 3 - ] |
|
||||
day 153 m * 2 + 5 /i + 365 y * +
|
||||
y 4 /i + y 100 /i - y 400 /i + 32045 -
|
||||
] ;
|
||||
|
||||
: julian-day-number>date ( n -- year month day )
|
||||
:: julian-day-number>date ( n -- year month day )
|
||||
#! Inverse of julian-day-number
|
||||
[
|
||||
32044 + a set
|
||||
4 a get * 3 + 146097 /i b set
|
||||
a get 146097 b get * 4 /i - c set
|
||||
4 c get * 3 + 1461 /i d set
|
||||
c get 1461 d get * 4 /i - e set
|
||||
5 e get * 2 + 153 /i m set
|
||||
100 b get * d get + 4800 -
|
||||
m get 10 /i + m get 3 +
|
||||
12 m get 10 /i * -
|
||||
e get 153 m get * 2 + 5 /i - 1+
|
||||
] with-scope ;
|
||||
[let* | a [ n 32044 + ]
|
||||
b [ 4 a * 3 + 146097 /i ]
|
||||
c [ a 146097 b * 4 /i - ]
|
||||
d [ 4 c * 3 + 1461 /i ]
|
||||
e [ c 1461 d * 4 /i - ]
|
||||
m [ 5 e * 2 + 153 /i ] |
|
||||
100 b * d + 4800 -
|
||||
m 10 /i + m 3 +
|
||||
12 m 10 /i * -
|
||||
e 153 m * 2 + 5 /i - 1+
|
||||
] ;
|
||||
|
||||
: >date< ( timestamp -- year month day )
|
||||
{ year>> month>> day>> } get-slots ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,21 @@
|
|||
USING: calendar.backend namespaces alien.c-types
|
||||
windows windows.kernel32 kernel math ;
|
||||
windows windows.kernel32 kernel math combinators.cleave
|
||||
combinators ;
|
||||
IN: calendar.windows
|
||||
|
||||
TUPLE: windows-calendar ;
|
||||
|
||||
T{ windows-calendar } calendar-backend set-global
|
||||
|
||||
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
|
||||
|
||||
M: windows-calendar gmt-offset ( -- hours minutes seconds )
|
||||
"TIME_ZONE_INFORMATION" <c-object>
|
||||
dup GetTimeZoneInformation {
|
||||
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
|
||||
{ [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
|
||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
|
||||
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
|
||||
{ [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
|
||||
drop TIME_ZONE_INFORMATION-Bias ] }
|
||||
{ [ dup TIME_ZONE_ID_DAYLIGHT = ] [
|
||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ]
|
||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi
|
||||
drop
|
||||
[ TIME_ZONE_INFORMATION-Bias ]
|
||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
|
||||
] }
|
||||
} cond ;
|
||||
} cond neg 60 /mod 0 ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@ circular strings ;
|
|||
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
|
||||
[ "test" ] [ "test" <circular> >string ] unit-test
|
||||
|
||||
[ "test" <circular> 5 swap nth ] must-fail
|
||||
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
|
|
@ -18,10 +17,13 @@ circular strings ;
|
|||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
||||
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
|
||||
[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
|
||||
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
|
||||
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
|
||||
|
||||
[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
|
||||
|
||||
! This no longer fails
|
||||
! [ "test" <circular> 5 swap nth ] must-fail
|
||||
! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
|
||||
|
|
|
|||
|
|
@ -18,9 +18,9 @@ M: circular length circular-seq length ;
|
|||
|
||||
M: circular virtual@ circular-wrap circular-seq ;
|
||||
|
||||
M: circular nth bounds-check virtual@ nth ;
|
||||
M: circular nth virtual@ nth ;
|
||||
|
||||
M: circular set-nth bounds-check virtual@ set-nth ;
|
||||
M: circular set-nth virtual@ set-nth ;
|
||||
|
||||
: change-circular-start ( n circular -- )
|
||||
#! change start to (start + n) mod length
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ TUPLE: pipe in out ;
|
|||
"\\\\.\\pipe\\factor-" %
|
||||
pipe counter #
|
||||
"-" %
|
||||
(random) #
|
||||
32 random-bits #
|
||||
"-" %
|
||||
millis #
|
||||
] "" make ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ $with-locals-note ;
|
|||
|
||||
HELP: [let
|
||||
{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
|
||||
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
|
||||
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel locals math math.functions prettyprint sequences ;"
|
||||
|
|
@ -38,6 +38,24 @@ HELP: [let
|
|||
}
|
||||
$with-locals-note ;
|
||||
|
||||
HELP: [let*
|
||||
{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
|
||||
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel locals math math.functions prettyprint sequences ;"
|
||||
":: frobnicate ( n seq -- newseq )"
|
||||
" [let* | a [ n 3 + ]"
|
||||
" b [ a 4 * ] |"
|
||||
" seq [ b / ] map ] ;"
|
||||
"1 { 32 48 } frobnicate ."
|
||||
"{ 2 3 }"
|
||||
}
|
||||
}
|
||||
$with-locals-note ;
|
||||
|
||||
{ POSTPONE: [let POSTPONE: [let* } related-words
|
||||
|
||||
HELP: [wlet
|
||||
{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
|
||||
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
|
||||
|
|
@ -106,6 +124,7 @@ $nl
|
|||
{ $subsection with-locals }
|
||||
"Lexical binding forms:"
|
||||
{ $subsection POSTPONE: [let }
|
||||
{ $subsection POSTPONE: [let* }
|
||||
{ $subsection POSTPONE: [wlet }
|
||||
"Lambda abstractions:"
|
||||
{ $subsection POSTPONE: [| }
|
||||
|
|
|
|||
|
|
@ -195,3 +195,36 @@ DEFER: xyzzy
|
|||
] unit-test
|
||||
|
||||
[ 5 ] [ 10 xyzzy ] unit-test
|
||||
|
||||
:: let*-test-1 ( a -- b )
|
||||
[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+ ] |
|
||||
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 ] ;
|
||||
|
||||
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
|
||||
|
||||
:: let*-test-4 ( a b -- c d )
|
||||
[let | a [ b ]
|
||||
b [ a ] |
|
||||
[let* | a' [ a ]
|
||||
a'' [ a' ]
|
||||
b' [ b ]
|
||||
b'' [ b' ] |
|
||||
a'' b'' ] ] ;
|
||||
|
||||
[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
|
|||
arrays macros splitting combinators prettyprint.backend
|
||||
definitions prettyprint hashtables combinators.lib
|
||||
prettyprint.sections sequences.private effects generic
|
||||
compiler.units combinators.cleave ;
|
||||
compiler.units combinators.cleave new-slots accessors ;
|
||||
IN: locals
|
||||
|
||||
! Inspired by
|
||||
|
|
@ -17,11 +17,15 @@ TUPLE: lambda vars body ;
|
|||
|
||||
C: <lambda> lambda
|
||||
|
||||
TUPLE: let bindings vars body ;
|
||||
TUPLE: let bindings body ;
|
||||
|
||||
C: <let> let
|
||||
|
||||
TUPLE: wlet bindings vars body ;
|
||||
TUPLE: let* bindings body ;
|
||||
|
||||
C: <let*> let*
|
||||
|
||||
TUPLE: wlet bindings body ;
|
||||
|
||||
C: <wlet> wlet
|
||||
|
||||
|
|
@ -137,7 +141,7 @@ M: object free-vars drop { } ;
|
|||
M: quotation free-vars { } [ add-if-free ] reduce ;
|
||||
|
||||
M: lambda free-vars
|
||||
dup lambda-vars swap lambda-body free-vars seq-diff ;
|
||||
dup vars>> swap body>> free-vars seq-diff ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! lambda-rewrite
|
||||
|
|
@ -164,12 +168,12 @@ M: callable block-body ;
|
|||
M: callable local-rewrite*
|
||||
[ [ local-rewrite* ] each ] [ ] make , ;
|
||||
|
||||
M: lambda block-vars lambda-vars ;
|
||||
M: lambda block-vars vars>> ;
|
||||
|
||||
M: lambda block-body lambda-body ;
|
||||
M: lambda block-body body>> ;
|
||||
|
||||
M: lambda local-rewrite*
|
||||
dup lambda-vars swap lambda-body
|
||||
dup vars>> swap body>>
|
||||
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
|
||||
|
||||
M: block lambda-rewrite*
|
||||
|
|
@ -187,24 +191,18 @@ M: object local-rewrite* , ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-locals ( seq -- words assoc )
|
||||
[
|
||||
"!" ?tail [ <local-reader> ] [ <local> ] if
|
||||
] map dup [
|
||||
dup
|
||||
[ dup word-name set ] each
|
||||
[
|
||||
dup local-reader? [
|
||||
<local-writer> dup word-name set
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] each
|
||||
] H{ } make-assoc ;
|
||||
: make-local ( name -- word )
|
||||
"!" ?tail [
|
||||
<local-reader>
|
||||
dup <local-writer> dup word-name set
|
||||
] [ <local> ] if
|
||||
dup dup word-name set ;
|
||||
|
||||
: make-local-words ( seq -- words assoc )
|
||||
[ dup <local-word> ] { } map>assoc
|
||||
dup values swap ;
|
||||
: make-locals ( seq -- words assoc )
|
||||
[ [ make-local ] map ] H{ } make-assoc ;
|
||||
|
||||
: make-local-word ( name -- word )
|
||||
<local-word> dup dup word-name set ;
|
||||
|
||||
: push-locals ( assoc -- )
|
||||
use get push ;
|
||||
|
|
@ -213,41 +211,75 @@ M: object local-rewrite* , ;
|
|||
use get delete ;
|
||||
|
||||
: (parse-lambda) ( assoc end -- quot )
|
||||
over push-locals parse-until >quotation swap pop-locals ;
|
||||
parse-until >quotation swap pop-locals ;
|
||||
|
||||
: parse-lambda ( -- lambda )
|
||||
"|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
|
||||
"|" parse-tokens make-locals dup push-locals
|
||||
\ ] (parse-lambda) <lambda> ;
|
||||
|
||||
: (parse-bindings) ( -- )
|
||||
: parse-binding ( -- pair/f )
|
||||
scan dup "|" = [
|
||||
drop
|
||||
drop f
|
||||
] [
|
||||
scan {
|
||||
{ "[" [ \ ] parse-until >quotation ] }
|
||||
{ "[|" [ parse-lambda ] }
|
||||
} case 2array ,
|
||||
(parse-bindings)
|
||||
} case 2array
|
||||
] if ;
|
||||
|
||||
: parse-bindings ( -- alist )
|
||||
scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
|
||||
: (parse-bindings) ( -- )
|
||||
parse-binding [
|
||||
first2 >r make-local r> 2array ,
|
||||
(parse-bindings)
|
||||
] when* ;
|
||||
|
||||
: parse-bindings ( -- bindings vars )
|
||||
[
|
||||
[ (parse-bindings) ] H{ } make-assoc
|
||||
dup push-locals
|
||||
] { } make swap ;
|
||||
|
||||
: parse-bindings* ( -- words assoc )
|
||||
[
|
||||
[
|
||||
namespace push-locals
|
||||
|
||||
(parse-bindings)
|
||||
] { } make-assoc
|
||||
] { } make swap ;
|
||||
|
||||
: (parse-wbindings) ( -- )
|
||||
parse-binding [
|
||||
first2 >r make-local-word r> 2array ,
|
||||
(parse-wbindings)
|
||||
] when* ;
|
||||
|
||||
: parse-wbindings ( -- bindings vars )
|
||||
[
|
||||
[ (parse-wbindings) ] H{ } make-assoc
|
||||
dup push-locals
|
||||
] { } make swap ;
|
||||
|
||||
: let-rewrite ( body bindings -- )
|
||||
<reversed> [
|
||||
>r 1array r> spin <lambda> [ call ] curry compose
|
||||
] assoc-each local-rewrite* \ call , ;
|
||||
|
||||
M: let local-rewrite*
|
||||
{ let-bindings let-vars let-body } get-slots -rot
|
||||
[ <reversed> ] 2apply
|
||||
[
|
||||
1array -rot second -rot <lambda>
|
||||
[ call ] curry compose
|
||||
] 2each local-rewrite* \ call , ;
|
||||
{ body>> bindings>> } get-slots let-rewrite ;
|
||||
|
||||
M: let* local-rewrite*
|
||||
{ body>> bindings>> } get-slots let-rewrite ;
|
||||
|
||||
M: wlet local-rewrite*
|
||||
dup wlet-bindings values over wlet-vars rot wlet-body
|
||||
<lambda> [ call ] curry compose local-rewrite* \ call , ;
|
||||
{ body>> bindings>> } get-slots
|
||||
[ [ ] curry ] assoc-map
|
||||
let-rewrite ;
|
||||
|
||||
: parse-locals
|
||||
: parse-locals ( -- vars assoc )
|
||||
parse-effect
|
||||
word [ over "declared-effect" set-word-prop ] when*
|
||||
effect-in make-locals ;
|
||||
effect-in make-locals dup push-locals ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
|
||||
|
|
@ -263,14 +295,17 @@ PRIVATE>
|
|||
: [| parse-lambda parsed ; parsing
|
||||
|
||||
: [let
|
||||
parse-bindings
|
||||
make-locals \ ] (parse-lambda)
|
||||
<let> parsed ; parsing
|
||||
scan "|" assert= parse-bindings
|
||||
\ ] (parse-lambda) <let> parsed ; parsing
|
||||
|
||||
: [let*
|
||||
scan "|" assert= parse-bindings*
|
||||
>r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
|
||||
parsing
|
||||
|
||||
: [wlet
|
||||
parse-bindings
|
||||
make-local-words \ ] (parse-lambda)
|
||||
<wlet> parsed ; parsing
|
||||
scan "|" assert= parse-wbindings
|
||||
\ ] (parse-lambda) <wlet> parsed ; parsing
|
||||
|
||||
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
|
||||
|
||||
|
|
@ -297,31 +332,30 @@ SYMBOL: |
|
|||
M: lambda pprint*
|
||||
<flow
|
||||
\ [| pprint-word
|
||||
dup lambda-vars pprint-vars
|
||||
dup vars>> pprint-vars
|
||||
\ | pprint-word
|
||||
f <inset lambda-body pprint-elements block>
|
||||
f <inset body>> pprint-elements block>
|
||||
\ ] pprint-word
|
||||
block> ;
|
||||
|
||||
: pprint-let ( body vars bindings -- )
|
||||
: pprint-let ( let word -- )
|
||||
pprint-word
|
||||
{ body>> bindings>> } get-slots
|
||||
\ | pprint-word
|
||||
t <inset
|
||||
<block
|
||||
values [ <block >r pprint-var r> pprint* block> ] 2each
|
||||
[ <block >r pprint-var r> pprint* block> ] assoc-each
|
||||
block>
|
||||
\ | pprint-word
|
||||
<block pprint-elements block>
|
||||
block> ;
|
||||
|
||||
M: let pprint*
|
||||
\ [let pprint-word
|
||||
{ let-body let-vars let-bindings } get-slots pprint-let
|
||||
block>
|
||||
\ ] pprint-word ;
|
||||
|
||||
M: wlet pprint*
|
||||
\ [wlet pprint-word
|
||||
{ wlet-body wlet-vars wlet-bindings } get-slots pprint-let
|
||||
\ ] pprint-word ;
|
||||
M: let pprint* \ [let pprint-let ;
|
||||
|
||||
M: wlet pprint* \ [wlet pprint-let ;
|
||||
|
||||
M: let* pprint* \ [let* pprint-let ;
|
||||
|
||||
PREDICATE: word lambda-word
|
||||
"lambda" word-prop >boolean ;
|
||||
|
|
@ -329,7 +363,7 @@ PREDICATE: word lambda-word
|
|||
M: lambda-word definer drop \ :: \ ; ;
|
||||
|
||||
M: lambda-word definition
|
||||
"lambda" word-prop lambda-body ;
|
||||
"lambda" word-prop body>> ;
|
||||
|
||||
: lambda-word-synopsis ( word -- )
|
||||
dup definer.
|
||||
|
|
@ -345,7 +379,7 @@ PREDICATE: macro lambda-macro
|
|||
M: lambda-macro definer drop \ MACRO:: \ ; ;
|
||||
|
||||
M: lambda-macro definition
|
||||
"lambda" word-prop lambda-body ;
|
||||
"lambda" word-prop body>> ;
|
||||
|
||||
M: lambda-macro synopsis* lambda-word-synopsis ;
|
||||
|
||||
|
|
@ -355,10 +389,10 @@ PREDICATE: method-body lambda-method
|
|||
M: lambda-method definer drop \ M:: \ ; ;
|
||||
|
||||
M: lambda-method definition
|
||||
"lambda" word-prop lambda-body ;
|
||||
"lambda" word-prop body>> ;
|
||||
|
||||
: method-stack-effect ( method -- effect )
|
||||
dup "lambda" word-prop lambda-vars
|
||||
dup "lambda" word-prop vars>>
|
||||
swap "method-generic" word-prop stack-effect
|
||||
dup [ effect-out ] when
|
||||
<effect> ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
USING: kernel math random namespaces random.mersenne-twister
|
||||
sequences tools.test ;
|
||||
IN: random.mersenne-twister.tests
|
||||
USE: tools.walker
|
||||
|
||||
: check-random ( max -- ? )
|
||||
dup >r random 0 r> between? ;
|
||||
|
|
@ -17,11 +16,11 @@ USE: tools.walker
|
|||
[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
|
||||
|
||||
[ 1333075495 ] [
|
||||
0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
|
||||
0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
|
||||
] unit-test
|
||||
|
||||
[ 1575309035 ] [
|
||||
0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng
|
||||
0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,9 +3,8 @@
|
|||
! mersenne twister based on
|
||||
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
|
||||
|
||||
USING: arrays kernel math namespaces sequences
|
||||
system init new-slots accessors
|
||||
math.ranges combinators.cleave circular random ;
|
||||
USING: arrays kernel math namespaces sequences system init
|
||||
new-slots accessors math.ranges combinators.cleave random ;
|
||||
IN: random.mersenne-twister
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -76,5 +75,3 @@ M: mersenne-twister random-32 ( mt -- r )
|
|||
dup mt-n < [ drop 0 pick mt-generate ] unless
|
||||
new-nth mt-temper
|
||||
swap [ 1+ ] change-i drop ;
|
||||
|
||||
[ millis <mersenne-twister> \ random set-global ] "random" add-init-hook
|
||||
|
|
|
|||
|
|
@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r )
|
|||
: (random-bytes) ( tuple n -- byte-array )
|
||||
[ drop random-32 ] with map >c-uint-array ;
|
||||
|
||||
DEFER: random
|
||||
SYMBOL: random-generator
|
||||
|
||||
: random-bytes ( n -- r )
|
||||
[
|
||||
4 /mod zero? [ 1+ ] unless
|
||||
\ random get swap (random-bytes)
|
||||
random-generator get swap (random-bytes)
|
||||
] keep head ;
|
||||
|
||||
: random-bits ( n -- r ) 2^ random ;
|
||||
|
||||
: random ( seq -- elt )
|
||||
dup empty? [
|
||||
drop f
|
||||
|
|
@ -35,5 +33,7 @@ DEFER: random
|
|||
] keep nth
|
||||
] if ;
|
||||
|
||||
: random-bits ( n -- r ) 2^ random ;
|
||||
|
||||
: with-random ( tuple quot -- )
|
||||
\ random swap with-variable ; inline
|
||||
random-generator swap with-variable ; inline
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@ M: email clone
|
|||
: message-id ( -- string )
|
||||
[
|
||||
"<" %
|
||||
2 big-random #
|
||||
64 random-bits #
|
||||
"-" %
|
||||
millis #
|
||||
"@" %
|
||||
|
|
|
|||
2
vm/io.h
2
vm/io.h
|
|
@ -12,5 +12,5 @@ DECLARE_PRIMITIVE(fclose);
|
|||
|
||||
/* Platform specific primitives */
|
||||
DECLARE_PRIMITIVE(open_file);
|
||||
DECLARE_PRIMITIVE(stat);
|
||||
DECLARE_PRIMITIVE(existsp);
|
||||
DECLARE_PRIMITIVE(read_dir);
|
||||
|
|
|
|||
18
vm/os-unix.c
18
vm/os-unix.c
|
|
@ -41,24 +41,10 @@ void ffi_dlclose(F_DLL *dll)
|
|||
dll->dll = NULL;
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(stat)
|
||||
DEFINE_PRIMITIVE(existsp)
|
||||
{
|
||||
struct stat sb;
|
||||
|
||||
if(stat(unbox_char_string(),&sb) < 0)
|
||||
{
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
}
|
||||
else
|
||||
{
|
||||
box_boolean(S_ISDIR(sb.st_mode));
|
||||
box_signed_4(sb.st_mode & ~S_IFMT);
|
||||
box_unsigned_8(sb.st_size);
|
||||
box_unsigned_8(sb.st_mtime);
|
||||
}
|
||||
box_boolean(stat(unbox_char_string(),&sb) >= 0);
|
||||
}
|
||||
|
||||
/* Allocates memory */
|
||||
|
|
|
|||
|
|
@ -87,14 +87,6 @@ const F_CHAR *vm_executable_path(void)
|
|||
return safe_strdup(full_path);
|
||||
}
|
||||
|
||||
void stat_not_found(void)
|
||||
{
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
dpush(F);
|
||||
}
|
||||
|
||||
void find_file_stat(F_CHAR *path)
|
||||
{
|
||||
// FindFirstFile is the only call that can stat c:\pagefile.sys
|
||||
|
|
@ -102,56 +94,45 @@ void find_file_stat(F_CHAR *path)
|
|||
HANDLE h;
|
||||
|
||||
if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
|
||||
stat_not_found();
|
||||
dpush(F);
|
||||
else
|
||||
{
|
||||
box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
|
||||
dpush(tag_fixnum(0));
|
||||
box_unsigned_8(
|
||||
(u64)st.nFileSizeLow | (u64)st.nFileSizeHigh << 32);
|
||||
|
||||
u64 lo = st.ftLastWriteTime.dwLowDateTime;
|
||||
u64 hi = st.ftLastWriteTime.dwHighDateTime;
|
||||
u64 modTime = (hi << 32) + lo;
|
||||
|
||||
box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
|
||||
FindClose(h);
|
||||
dpush(T);
|
||||
}
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(stat)
|
||||
DEFINE_PRIMITIVE(existsp)
|
||||
{
|
||||
HANDLE h;
|
||||
BY_HANDLE_FILE_INFORMATION bhfi;
|
||||
|
||||
F_CHAR *path = unbox_u16_string();
|
||||
//wprintf(L"path = %s\n", path);
|
||||
h = CreateFileW(path,
|
||||
GENERIC_READ,
|
||||
FILE_SHARE_READ,
|
||||
NULL,
|
||||
OPEN_EXISTING,
|
||||
FILE_FLAG_BACKUP_SEMANTICS,
|
||||
NULL);
|
||||
HANDLE h = CreateFileW(path,
|
||||
GENERIC_READ,
|
||||
FILE_SHARE_READ,
|
||||
NULL,
|
||||
OPEN_EXISTING,
|
||||
FILE_FLAG_BACKUP_SEMANTICS,
|
||||
NULL);
|
||||
|
||||
if(h == INVALID_HANDLE_VALUE)
|
||||
{
|
||||
find_file_stat(path);
|
||||
// FindFirstFile is the only call that can stat c:\pagefile.sys
|
||||
WIN32_FIND_DATA st;
|
||||
HANDLE h;
|
||||
|
||||
if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
|
||||
dpush(F);
|
||||
else
|
||||
{
|
||||
FindClose(h);
|
||||
dpush(T);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
if(!GetFileInformationByHandle(h, &bhfi))
|
||||
stat_not_found();
|
||||
else {
|
||||
box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
|
||||
dpush(tag_fixnum(0));
|
||||
box_unsigned_8(
|
||||
(u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32);
|
||||
u64 lo = bhfi.ftLastWriteTime.dwLowDateTime;
|
||||
u64 hi = bhfi.ftLastWriteTime.dwHighDateTime;
|
||||
u64 modTime = (hi << 32) + lo;
|
||||
|
||||
box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
|
||||
}
|
||||
box_boolean(GetFileInformationByHandle(h, &bhfi));
|
||||
CloseHandle(h);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ void *primitives[] = {
|
|||
primitive_eq,
|
||||
primitive_getenv,
|
||||
primitive_setenv,
|
||||
primitive_stat,
|
||||
primitive_existsp,
|
||||
primitive_read_dir,
|
||||
primitive_data_gc,
|
||||
primitive_code_gc,
|
||||
|
|
|
|||
Loading…
Reference in New Issue