Merge commit 'erg/master'

extra/assocs/lib/lib.factor

@@ -11,14 +11,17 @@ IN: assocs.lib
 
 ! set-hash with alternative stack effects
 
-: put-hash* ( table key value -- ) swap rot set-at ;
+: put-hash* ( table key value -- ) spin set-at ;
 
 : put-hash ( table key value -- table ) swap pick set-at ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : set-hash-stack ( value key seq -- )
-  dupd [ key? ] when find-last nip set-at ;
+    dupd [ key? ] with find-last nip set-at ;
 
 : at-default ( key assoc -- value/key )
     dupd at [ nip ] when* ;
+
+: at-peek ( key assoc -- value ? )
+    at* dup >r [ peek ] when r> ;

extra/automata/ui/ui.factor

@@ -14,7 +14,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
        ui.gadgets.packs
        ui.gadgets.grids
        ui.gadgets.theme
-       namespaces.lib hashtables.lib vars
+       namespaces.lib assocs.lib vars
        rewrite-closures automata ;
 
 IN: automata.ui
@@ -85,4 +85,4 @@ over @center grid-add
 
 : automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
 
-MAIN: automata-window
+MAIN: automata-window

extra/boids/ui/ui.factor

@@ -20,7 +20,7 @@ USING: kernel namespaces
        ui.gadgets.grids
        ui.gestures
        combinators.cleave
-       hashtables.lib vars rewrite-closures boids ;
+       assocs.lib vars rewrite-closures boids ;
 
 IN: boids.ui
 
@@ -163,4 +163,4 @@ VARS: population-label cohesion-label alignment-label separation-label ;
 
 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
 
-MAIN: boids-window
+MAIN: boids-window

extra/calendar/calendar.factor

@@ -4,7 +4,8 @@
 USING: arrays hashtables io io.streams.string kernel math
 math.vectors math.functions math.parser namespaces sequences
 strings tuples system debugger combinators vocabs.loader
-calendar.backend structs alien.c-types math.vectors ;
+calendar.backend structs alien.c-types math.vectors
+math.ranges shuffle ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
@@ -115,14 +116,18 @@ GENERIC: +second ( timestamp x -- timestamp )
 
 : /rem ( f n -- q r )
     #! q is positive or negative, r is positive from 0 <= r < n
-    [ /f floor >bignum ] 2keep rem ;
+    [ /f floor >integer ] 2keep rem ;
 
 : float>whole-part ( float -- int float )
-    [ floor >bignum ] keep over - ;
+    [ floor >integer ] keep over - ;
 
-: leap-year? ( year -- ? )
+GENERIC: leap-year? ( obj -- ? )
+M: integer leap-year? ( year -- ? )
     dup 100 mod zero? 400 4 ? mod zero? ;
 
+M: timestamp leap-year? ( timestamp -- ? )
+    timestamp-year leap-year? ;
+
 : adjust-leap-year ( timestamp -- timestamp )
     dup >date< 29 = swap 2 = and swap leap-year? not and [
         dup >r timestamp-year 3 1 r> [ set-date ] keep
@@ -161,7 +166,7 @@ M: real +minute ( timestamp n -- timestamp )
     float>whole-part rot swap 60 * +second swap +minute ;
 
 M: number +second ( timestamp n -- timestamp )
-    over timestamp-second + 60 /rem >r >bignum r>
+    over timestamp-second + 60 /rem >r >integer r>
     pick set-timestamp-second +minute ;
 
 : +dt ( timestamp dt -- timestamp )
@@ -178,6 +183,9 @@ M: number +second ( timestamp n -- timestamp )
     <timestamp> [ 0 seconds +dt ] keep
     [ = [ "invalid timestamp" throw ] unless ] keep ;
 
+: make-date ( year month day -- timestamp )
+    0 0 0 gmt-offset make-timestamp ;
+
 : array>dt ( vec -- dt ) { dt f } swap append >tuple ;
 : +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
 
@@ -214,14 +222,14 @@ M: timestamp <=> ( ts1 ts2 -- n )
     [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
     [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
 
-: unix-1970
+: unix-1970 ( -- timestamp )
     1970 1 1 0 0 0 0 <timestamp> ;
 
 : unix-time>timestamp ( n -- timestamp )
     >r unix-1970 r> seconds +dt ;
 
 : timestamp>unix-time ( timestamp -- n )
-    unix-1970 timestamp- >bignum ;
+    unix-1970 timestamp- >integer ;
 
 : timestamp>timeval ( timestamp -- timeval )
     timestamp>unix-time 1000 * make-timeval ;
@@ -240,14 +248,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : from-now ( dt -- timestamp ) now swap +dt ;
 : ago ( dt -- timestamp ) before from-now ;
 
-: days-in-year ( year -- n ) leap-year? 366 365 ? ;
 : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
-: days-in-month ( year month -- n )
-    swap leap-year? [
-        [ day-counts nth ] keep 2 = [ 1+ ] when
-    ] [
-        day-counts nth
-    ] if ;
 
 : zeller-congruence ( year month day -- n )
     #! Zeller Congruence
@@ -258,33 +259,79 @@ M: timestamp <=> ( ts1 ts2 -- n )
         [ 1+ 3 * 5 /i + ] keep 2 * + r>
     1+ + 7 mod ;
 
-: day-of-week ( timestamp -- n )
+GENERIC: days-in-year ( obj -- n )
+
+M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
+M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
+
+GENERIC: days-in-month ( obj -- n )
+
+M: array days-in-month ( obj -- n )
+    first2 dup 2 = [
+        drop leap-year? 29 28 ?
+    ] [
+        nip day-counts nth
+    ] if ;
+
+M: timestamp days-in-month ( timestamp -- n )
+    { timestamp-year timestamp-month } get-slots 2array days-in-month ;
+
+GENERIC: day-of-week ( obj -- n )
+
+M: timestamp day-of-week ( timestamp -- n )
     >date< zeller-congruence ;
 
-: day-of-year ( timestamp -- n )
+M: array day-of-week ( array -- n )
-    [
+    first3 zeller-congruence ;
-        [ timestamp-year leap-year? ] keep
-        [ >date< 3array ] keep timestamp-year 3 1 3array <=>
-        0 >= and 1 0 ?
-    ] keep
-    [ timestamp-month day-counts swap head-slice sum + ] keep
-    timestamp-day + ;
 
-: print-day ( n -- )
+GENERIC: day-of-year ( obj -- n )
+
+M: array day-of-year ( array -- n )
+    first3
+    3dup day-counts rot head-slice sum +
+    swap leap-year? [
+        -roll
+        pick 3 1 make-date >r make-date r>
+        <=> 0 >= [ 1+ ] when
+    ] [
+        3nip
+    ] if ;
+
+M: timestamp day-of-year ( timestamp -- n )
+    { timestamp-year timestamp-month timestamp-day } get-slots
+    3array day-of-year ;
+
+GENERIC: day. ( obj -- )
+
+M: integer day. ( n -- )
     number>string dup length 2 < [ bl ] when write ;
 
-: print-month ( year month -- )
+M: timestamp day. ( timestamp -- )
+    timestamp-day day. ;
+
+GENERIC: month. ( obj -- )
+
+M: array month. ( pair -- )
+    first2
     [ month-names nth write bl number>string print ] 2keep
     [ 1 zeller-congruence ] 2keep
-    days-in-month day-abbreviations2 " " join print
+    2array days-in-month day-abbreviations2 " " join print
     over "   " <repetition> concat write
     [
-        [ 1+ print-day ] keep
+        [ 1+ day. ] keep
         1+ + 7 mod zero? [ nl ] [ bl ] if
     ] with each nl ;
 
-: print-year ( year -- )
+M: timestamp month. ( timestamp -- )
-    12 [ 1+ print-month nl ] with each ;
+    { timestamp-year timestamp-month } get-slots 2array month. ;
+
+GENERIC: year. ( obj -- )
+
+M: integer year. ( n -- )
+    12 [ 1+ 2array month. nl ] with each ;
+
+M: timestamp year. ( timestamp -- )
+    timestamp-year year. ;
 
 : pad-00 number>string 2 CHAR: 0 pad-left write ;
 
@@ -298,9 +345,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
     timestamp-second >fixnum pad-00 ;
 
 : timestamp>string ( timestamp -- str )
-    [
+    [ (timestamp>string) ] string-out ;
-        (timestamp>string)
-    ] string-out ;
 
 : timestamp>http-string ( timestamp -- str )
     #! http timestamp format
@@ -319,9 +364,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
     timestamp-second >fixnum pad-00 CHAR: Z write1 ;
 
 : timestamp>rfc3339 ( timestamp -- str )
-    >gmt [
+    >gmt [ (timestamp>rfc3339) ] string-out ;
-        (timestamp>rfc3339)
-    ] string-out ;
 
 : expect read1 assert= ;
 
@@ -340,9 +383,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
     0 <timestamp> ;
 
 : rfc3339>timestamp ( str -- timestamp )
-    [
+    [ (rfc3339>timestamp) ] string-in ;
-        (rfc3339>timestamp)
-    ] string-in ;
 
 : file-time-string ( timestamp -- string )
     [
@@ -370,6 +411,23 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : friday ( timestamp -- timestamp ) 5 day-this-week ;
 : saturday ( timestamp -- timestamp ) 6 day-this-week ;
 
+: beginning-of-day ( timestamp -- new-timestamp )
+    clone dup >r 0 0 0 r>
+    { set-timestamp-hour set-timestamp-minute set-timestamp-second }
+    set-slots ; inline
+
+: beginning-of-month ( timestamp -- new-timestamp )
+    beginning-of-day 1 over set-timestamp-day ;
+
+: beginning-of-week ( timestamp -- new-timestamp )
+    beginning-of-day sunday ;
+
+: beginning-of-year ( timestamp -- new-timestamp )
+    beginning-of-month 1 over set-timestamp-month ;
+
+: seconds-since-midnight ( timestamp -- x )
+    dup beginning-of-day timestamp- ;
+
 {
     { [ unix? ] [ "calendar.unix" ] }
     { [ windows? ] [ "calendar.windows" ] }

extra/combinators/lib/lib.factor

@@ -191,3 +191,23 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 
 : either ( object first second -- ? )
     >r keep swap [ r> drop ] [ r> call ] ?if ; inline
+
+: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
+    >r pick >r with r> r> swapd with ;
+
+: or? ( obj quot1 quot2 -- ? )
+    >r keep r> rot [ 2nip ] [ call ] if* ; inline
+
+: and? ( obj quot1 quot2 -- ? )
+    >r keep r> rot [ call ] [ 2drop f ] if ; inline
+
+: prepare-index ( seq quot -- seq n quot )
+    >r dup length r> ; inline
+
+: each-index ( seq quot -- )
+    #! quot: ( elt index -- )
+    prepare-index 2each ; inline
+
+: map-index ( seq quot -- )
+    #! quot: ( elt index -- obj )
+    prepare-index 2map ; inline

extra/hashtables/lib/lib.factor

@@ -1,19 +0,0 @@
-
-USING: kernel sequences assocs ;
-
-IN: hashtables.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ref-hash ( table key -- value ) swap at ;
-
-! set-hash with alternative stack effects
-
-: put-hash* ( table key value -- ) spin set-at ;
-
-: put-hash ( table key value -- table ) swap pick set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-hash-stack ( value key seq -- )
-  dupd [ key? ] with find-last nip set-at ;

extra/hexdump/hexdump.factor

@@ -1,4 +1,6 @@
-USING: arrays io io.streams.string kernel math math.parser namespaces prettyprint sequences splitting strings ;
+USING: arrays combinators.lib io io.streams.string
+kernel math math.parser namespaces prettyprint
+sequences splitting strings ;
 IN: hexdump
 
 <PRIVATE
@@ -6,12 +8,16 @@ IN: hexdump
 : header. ( len -- )
     "Length: " write dup unparse write ", " write >hex write "h" write nl ;
 
-: offset. ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+: offset. ( lineno -- )
-: h-pad. ( digit -- ) >hex 2 CHAR: 0 pad-left write ;
+    16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+
+: h-pad. ( digit -- )
+    >hex 2 CHAR: 0 pad-left write ;
+
 : line. ( str n -- )
     offset.
     dup [ h-pad. " " write ] each
-    16 over length - "   " <array> concat write
+    16 over length - 3 * CHAR: \s <string> write
     [ dup printable? [ drop CHAR: . ] unless write1 ] each
     nl ;
 
@@ -19,9 +25,8 @@ PRIVATE>
 : hexdump ( seq -- str )
     [
         dup length header.
-        16 <sliced-groups> dup length [ line. ] 2each
+        16 <sliced-groups> [ line. ] each-index
     ] string-out ;
 
 : hexdump. ( seq -- )
     hexdump write ;
-

extra/http/client/client.factor

@@ -9,11 +9,14 @@ IN: http.client
     #! Extract the host name and port number from an HTTP URL.
     ":" split1 [ string>number ] [ 80 ] if* ;
 
+SYMBOL: domain
+
 : parse-url ( url -- host resource )
-    "http://" ?head [
+    dup "https://" head? [
-        "URL must begin with http://" throw
+        "ssl not yet supported: " swap append throw
-    ] unless
+    ] when "http://" ?head drop
-    "/" split1 [ "/" swap append ] [ "/" ] if* ;
+    "/" split1 [ "/" swap append ] [ "/" ] if*
+    >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
 
 : parse-response ( line -- code )
     "HTTP/" ?head [ " " split1 nip ] when
@@ -52,7 +55,9 @@ DEFER: http-get-stream
 
 : http-get ( url -- code headers string )
     #! Opens a stream for reading from an HTTP URL.
-    http-get-stream [ stdio get contents ] with-stream ;
+    [
+        http-get-stream [ stdio get contents ] with-stream
+    ] with-scope ;
 
 : download ( url file -- )
     #! Downloads the contents of a URL to a file.

extra/io/unix/backend/select/select.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax kernel io.nonblocking io.unix.backend
-bit-arrays sequences assocs unix math namespaces ;
+bit-arrays sequences assocs unix math namespaces structs ;
 IN: io.unix.backend.select
 
 TUPLE: unix-select-io ;

extra/namespaces/lib/lib.factor

@@ -1,8 +1,8 @@
 
-! USING: kernel quotations namespaces sequences hashtables.lib ;
+! USING: kernel quotations namespaces sequences assocs.lib ;
 
 USING: kernel namespaces namespaces.private quotations sequences
-       hashtables.lib ;
+       assocs.lib ;
 
 IN: namespaces.lib
 
@@ -16,4 +16,4 @@ IN: namespaces.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: set* ( val var -- ) namestack* set-hash-stack ;
+: set* ( val var -- ) namestack* set-hash-stack ;

extra/shufflers/shufflers-docs.factor

@@ -1,4 +1,5 @@
-USING: shufflers help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: shufflers
 
 HELP: SHUFFLE:
 { $syntax "SHUFFLE: alphabet #" }

extra/shufflers/shufflers.factor

@@ -29,7 +29,7 @@ IN: shufflers
 : define-shuffles ( names max-out -- )
     in-shuffle over length make-shuffles [
         [ shuffle>string create-in ] keep
-        shuffle>quot dupd define-compound put-effect
+        shuffle>quot dupd define put-effect
     ] with each out-shuffle ;
 
 : SHUFFLE:

extra/state-machine/state-machine.factor

@@ -7,7 +7,7 @@ IN: state-machine
     ";" parse-tokens
     [ length ] keep
     unclip add
-    [ create-in swap 1quotation define-compound ] 2each ; parsing
+    [ create-in swap 1quotation define ] 2each ; parsing
 
 TUPLE: state place data ;
 
@@ -27,7 +27,7 @@ M: missing-state error.
 
 : define-machine ( word state-class -- )
     execute make-machine
-    >r over r> define-compound
+    >r over r> define
     "state-table" set-word-prop ;
 
 : MACHINE:

extra/strings/lib/lib.factor

@@ -1,8 +1,14 @@
-
+USING: math arrays sequences kernel splitting strings ;
-USING: math arrays sequences ;
-
 IN: strings.lib
 
 : char>digit ( c -- i ) 48 - ;
 
 : string>digits ( s -- seq ) [ char>digit ] { } map-as ;
+
+: >Upper ( str -- str )
+    dup empty? [
+        unclip ch>upper 1string swap append
+    ] unless ;
+
+: >Upper-dashes ( str -- str )
+    "-" split [ >Upper ] map "-" join ;

extra/tools/deploy/shaker/shaker.factor

@@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays
 continuations math definitions mirrors splitting parser classes
 inspector layouts vocabs.loader prettyprint.config prettyprint
 debugger io.streams.c io.streams.duplex io.files io.backend
-quotations words.private tools.deploy.config ;
+quotations words.private tools.deploy.config compiler.units ;
 IN: tools.deploy.shaker
 
 : show ( msg -- )

misc/factor.sh

@@ -237,19 +237,19 @@ maybe_download_dlls() {
 	fi
 }
 
+get_config_info() {
+	check_installed_programs
+	find_build_info
+	check_libraries
+}
+
 bootstrap() {
 	./$FACTOR_BINARY -i=$BOOT_IMAGE
 }
 
-usage() {
-	echo "usage: $0 install|install-x11|update|quick-update"
-}
-
 install() {
 	check_factor_exists
-	check_installed_programs
+	get_config_info
-	find_build_info
-	check_libraries
 	git_clone
 	cd_factor
 	make_factor
@@ -259,9 +259,7 @@ install() {
 }
 
 update() {
-	check_installed_programs
+	get_config_info
-	find_build_info
-	check_libraries
 	git_pull_factorcode
 	make_clean
 	make_factor
@@ -288,11 +286,16 @@ install_libraries() {
 	sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap
 }
 
+usage() {
+	echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap"
+}
+
 case "$1" in
 	install) install ;;
 	install-x11) install_libraries; install ;;
 	self-update) update; make_boot_image; bootstrap;;
 	quick-update) update; refresh_image ;;
 	update) update; update_bootstrap ;;
+	bootstrap) get_config_info; bootstrap ;;
 	*) usage ;;
 esac