Merge branch 'master' of git://factorcode.org/git/factor into tangle

core/bootstrap/image/image.factor

@@ -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

core/bootstrap/primitives.factor

@@ -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" }

core/bootstrap/stage2.factor

@@ -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

core/bootstrap/syntax.factor

@@ -21,6 +21,7 @@ IN: bootstrap.syntax
     "C:"
     "CHAR:"
     "DEFER:"
+    "ERROR:"
     "F{"
     "FV{"
     "FORGET:"

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 ;

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: 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 ;
 

core/compiler/tests/intrinsics.factor

@@ -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 ;
 

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 ;
 

core/inference/known-words/known-words.factor

@@ -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
 

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 directory? } ;
-! { $subsection file-modified }
-{ $subsection stat } ;
 
 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 } }

core/io/files/files.factor

@@ -86,14 +86,11 @@ SYMBOL: +socket+
 SYMBOL: +unknown+
 
 ! File metadata
-: stat ( path -- directory? permissions length modified )
+: exists? ( path -- ? )
-    normalize-pathname (stat) ;
+    normalize-pathname (exists?) ;
 
-: file-modified ( path -- n ) stat >r 3drop r> ;
+: directory? ( path -- ? )
-
+    file-info file-info-type +directory+ = ;
-: exists? ( path -- ? ) file-modified >boolean ;
-
-: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
 
 ! Current working directory
 HOOK: cd io-backend ( path -- )

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 <mersenne-twister> random-generator set-global ]
+"generator.random" add-init-hook

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 ;

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" ] }

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
-    [
+    [let* | a [ 14 month - 12 /i ]
-        14 pick - 12 /i a set
+            y [ year 4800 + a - ]
-        pick 4800 + a get - y set
+            m [ month 12 a * + 3 - ] |
-        over 12 a get * + 3 - m set
+        day 153 m * 2 + 5 /i + 365 y * +
-        2nip 153 m get * 2 + 5 /i + 365 y get * +
+        y 4 /i + y 100 /i - y 400 /i + 32045 -
-        y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
+    ] ;
-    ] with-scope ;
 
-: julian-day-number>date ( n -- year month day )
+:: julian-day-number>date ( n -- year month day )
     #! Inverse of julian-day-number
-    [
+    [let* | a [ n 32044 + ]
-        32044 + a set
+            b [ 4 a * 3 + 146097 /i ]
-        4 a get * 3 + 146097 /i b set
+            c [ a 146097 b * 4 /i - ]
-        a get 146097 b get * 4 /i - c set
+            d [ 4 c * 3 + 1461 /i ]
-        4 c get * 3 + 1461 /i d set
+            e [ c 1461 d * 4 /i - ]
-        c get 1461 d get * 4 /i - e set
+            m [ 5 e * 2 + 153 /i ] |
-        5 e get * 2 + 153 /i m set
+        100 b * d + 4800 -
-        100 b get * d get + 4800 -
+        m 10 /i + m 3 +
-        m get 10 /i + m get 3 +
+        12 m 10 /i * -
-        12 m get 10 /i * -
+        e 153 m * 2 + 5 /i - 1+
-        e get 153 m get * 2 + 5 /i - 1+
+    ] ;
-    ] with-scope ;
 
 : >date< ( timestamp -- year month day )
     { year>> month>> day>> } get-slots ;

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" <c-object>
     dup GetTimeZoneInformation {
-        { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
+        { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
-        { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
+        { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
-            [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
+            drop TIME_ZONE_INFORMATION-Bias ] }
         { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
-            [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
+            drop
-            [ TIME_ZONE_INFORMATION-DaylightBias ] bi
+            [ TIME_ZONE_INFORMATION-Bias ]
+            [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
         ] }
-    } cond ;
+    } cond neg 60 /mod 0 ;

extra/circular/circular-tests.factor

@@ -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

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

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 ;

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: [| }

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
+

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> 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 )
+: make-local ( name -- word )
-    [
+    "!" ?tail [
-        "!" ?tail [ <local-reader> ] [ <local> ] if
+        <local-reader>
-    ] map dup [
+        dup <local-writer> dup word-name set
-        dup
+    ] [ <local> ] if
-        [ dup word-name set ] each
+    dup dup word-name set ;
-        [
-            dup local-reader? [
-                <local-writer> dup word-name set
-            ] [
-                drop
-            ] if
-        ] each
-    ] H{ } make-assoc ;
 
-: make-local-words ( seq -- words assoc )
+: make-locals ( seq -- words assoc )
-    [ dup <local-word> ] { } map>assoc
+    [ [ make-local ] map ] H{ } make-assoc ;
-    dup values swap ;
+
+: 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 ,
+        } case 2array
-        (parse-bindings)
     ] if ;
 
-: parse-bindings ( -- alist )
+: (parse-bindings) ( -- )
-    scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
+    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
+    { body>> bindings>> } get-slots let-rewrite ;
-    [ <reversed> ] 2apply
+
-    [
+M: let* local-rewrite*
-        1array -rot second -rot <lambda>
+    { body>> bindings>> } get-slots let-rewrite ;
-        [ call ] curry compose
-    ] 2each local-rewrite* \ call , ;
 
 M: wlet local-rewrite*
-    dup wlet-bindings values over wlet-vars rot wlet-body
+    { body>> bindings>> } get-slots
-    <lambda> [ call ] curry compose local-rewrite* \ call , ;
+    [ [ ] 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
+    scan "|" assert= parse-bindings
-    make-locals \ ] (parse-lambda)
+\ ] (parse-lambda) <let> parsed ; parsing
-    <let> parsed ; parsing
+
+: [let*
+    scan "|" assert= parse-bindings*
+    >r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
+    parsing
 
 : [wlet
-    parse-bindings
+    scan "|" assert= parse-wbindings
-    make-local-words \ ] (parse-lambda)
+    \ ] (parse-lambda) <wlet> parsed ; parsing
-    <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> ;
+    block>
-
-M: let pprint*
-    \ [let pprint-word
-    { let-body let-vars let-bindings } get-slots pprint-let
     \ ] pprint-word ;
 
-M: wlet pprint*
+M: let pprint* \ [let pprint-let ;
-    \ [wlet pprint-word
+
-    { wlet-body wlet-vars wlet-bindings } get-slots pprint-let
+M: wlet pprint* \ [wlet pprint-let ;
-    \ ] pprint-word ;
+
+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> ;

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
 
 

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
+USING: arrays kernel math namespaces sequences system init
-system init new-slots accessors
+new-slots accessors math.ranges combinators.cleave random ;
-math.ranges combinators.cleave circular 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

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

extra/smtp/smtp.factor

@@ -125,7 +125,7 @@ M: email clone
 : message-id ( -- string )
     [
         "<" %
-        2 big-random #
+        64 random-bits #
         "-" %
         millis #
         "@" %

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);

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;
-
+	box_boolean(stat(unbox_char_string(),&sb) >= 0);
-	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);
-	}
 }
 
 /* Allocates memory */

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,
+	HANDLE h = CreateFileW(path,
-					GENERIC_READ,
+			GENERIC_READ,
-					FILE_SHARE_READ,
+			FILE_SHARE_READ,
-					NULL,
+			NULL,
-					OPEN_EXISTING,
+			OPEN_EXISTING,
-					FILE_FLAG_BACKUP_SEMANTICS,
+			FILE_FLAG_BACKUP_SEMANTICS,
-					NULL);
+			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))
+	box_boolean(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);
-	}
 	CloseHandle(h);
 }
 

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,