diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f5f4d70d14..52a2496755 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -349,7 +349,7 @@ M: curry ' [ { dictionary source-files - typemap builtins classr 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 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a4e87f28d8..e7e90d8dd0 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -21,6 +21,7 @@ IN: bootstrap.syntax "C:" "CHAR:" "DEFER:" + "ERROR:" "F{" "FV{" "FORGET:" diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index f97f088845..3322c3b043 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -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 ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index e60d3ba223..e47dbd20e5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ; PREDICATE: word class ( obj -- ? ) "class" word-prop ; SYMBOL: typemap +SYMBOL: class-map SYMBOL: classboolean ; { [ 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 classfixnum (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 ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 61e09d894e..0b3123c87b 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 235c2924bb..08fb56ced7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -354,7 +354,7 @@ M: object infer-call \ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } set-primitive-effect +\ exists? { string } { object } set-primitive-effect \ (directory) { string } { array } set-primitive-effect diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1ee9d19e4a..1a3bde0e5c 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -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 } " and " { $link } ", to prepare a pathname before passing it to underlying code." } ; +{ $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; HELP: ( str -- pathname ) { $values { "str" "a pathname string" } { "pathname" pathname } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 0d00197415..3de7559303 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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 -- ) diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor old mode 100644 new mode 100755 index 7132860e1c..b61e002526 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -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 random-generator set-global ] +"generator.random" add-init-hook diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index ea404d6efa..19734a3266 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -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 ; diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index d7aa90c464..76ce27975b 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -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" ] } diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 457b0bea11..7347363e5b 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -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 ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index acbae2fcd3..6986902ff1 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -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" 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 ; diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor old mode 100644 new mode 100755 index 8ca4574885..9023ab1dba --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,6 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,10 +17,13 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test [ "bcd" ] [ 3 "abcd" [ over push-circular ] each >string ] unit-test [ { 0 0 } ] [ { 0 0 } -1 over change-circular-start >array ] unit-test + +! This no longer fails +! [ "test" 5 swap nth ] must-fail +! [ "foo" CHAR: b 3 rot set-nth ] must-fail diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor old mode 100644 new mode 100755 index 8760e26586..08deb004e8 --- a/extra/circular/circular.factor +++ b/extra/circular/circular.factor @@ -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 diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index eb6dae2a0a..6fd38e74b2 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -56,7 +56,7 @@ TUPLE: pipe in out ; "\\\\.\\pipe\\factor-" % pipe counter # "-" % - (random) # + 32 random-bits # "-" % millis # ] "" make ; diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 62f2eac513..372a567550 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -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: [| } diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index bd1e62f22a..4ee9b48bb7 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -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 + diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 9f96a3444d..cc1785ff62 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -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 -TUPLE: let bindings vars body ; +TUPLE: let bindings body ; C: let -TUPLE: wlet bindings vars body ; +TUPLE: let* bindings body ; + +C: let* + +TUPLE: wlet bindings body ; C: 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 , ; M: block lambda-rewrite* @@ -187,24 +191,18 @@ M: object local-rewrite* , ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: make-locals ( seq -- words assoc ) - [ - "!" ?tail [ ] [ ] if - ] map dup [ - dup - [ dup word-name set ] each - [ - dup local-reader? [ - dup word-name set - ] [ - drop - ] if - ] each - ] H{ } make-assoc ; +: make-local ( name -- word ) + "!" ?tail [ + + dup dup word-name set + ] [ ] if + dup dup word-name set ; -: make-local-words ( seq -- words assoc ) - [ dup ] { } map>assoc - dup values swap ; +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name -- 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) ; + "|" parse-tokens make-locals dup push-locals + \ ] (parse-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 -- ) + [ + >r 1array r> spin [ call ] curry compose + ] assoc-each local-rewrite* \ call , ; M: let local-rewrite* - { let-bindings let-vars let-body } get-slots -rot - [ ] 2apply - [ - 1array -rot second -rot - [ 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 - [ 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) @@ -263,14 +295,17 @@ PRIVATE> : [| parse-lambda parsed ; parsing : [let - parse-bindings - make-locals \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-bindings +\ ] (parse-lambda) parsed ; parsing + +: [let* + scan "|" assert= parse-bindings* + >r \ ] parse-until >quotation parsed r> pop-locals ; + parsing : [wlet - parse-bindings - make-local-words \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-wbindings + \ ] (parse-lambda) parsed ; parsing MACRO: with-locals ( form -- quot ) lambda-rewrite ; @@ -297,31 +332,30 @@ SYMBOL: | M: lambda pprint* > pprint-vars \ | pprint-word - f + f > pprint-elements block> \ ] pprint-word block> ; -: pprint-let ( body vars bindings -- ) +: pprint-let ( let word -- ) + pprint-word + { body>> bindings>> } get-slots \ | pprint-word t r pprint-var r> pprint* block> ] 2each + [ r pprint-var r> pprint* block> ] assoc-each block> \ | pprint-word - 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 ; diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor old mode 100644 new mode 100755 index afd9d085b6..49bf4ad3f3 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -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 diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 79101c083e..73f241a370 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -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 \ random set-global ] "random" add-init-hook diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100644 new mode 100755 index bbf54e21eb..0d8b137fc5 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -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 diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index f7cdf9e64d..e15a90eda9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -125,7 +125,7 @@ M: email clone : message-id ( -- string ) [ "<" % - 2 big-random # + 64 random-bits # "-" % millis # "@" % diff --git a/vm/io.h b/vm/io.h index a19da3887c..6291db50ee 100755 --- a/vm/io.h +++ b/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); diff --git a/vm/os-unix.c b/vm/os-unix.c index 37dceb0d37..74320288aa 100755 --- a/vm/os-unix.c +++ b/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 */ diff --git a/vm/os-windows.c b/vm/os-windows.c index f9b80ea32a..1be41f8b57 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -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); } diff --git a/vm/primitives.c b/vm/primitives.c index d1d956dca0..ce26c20f63 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -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,