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

basis/calendar/calendar.factor

@@ -51,8 +51,16 @@ CONSTANT: month-names
         "July" "August" "September" "October" "November" "December"
     }
 
-: month-name ( n -- string )
+<PRIVATE
-    check-month 1 - month-names nth ;
+
+: (month-name) ( n -- string ) 1 - month-names nth ;
+
+PRIVATE>
+
+GENERIC: month-name ( obj -- string )
+
+M: integer month-name check-month 1 - month-names nth ;
+M: timestamp month-name month>> 1 - month-names nth ;
 
 CONSTANT: month-abbreviations
     {
@@ -65,12 +73,8 @@ CONSTANT: month-abbreviations
 
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 
-: day-names ( -- array )
+CONSTANT: day-names
-    {
+    { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
-        "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
-    } ;
-
-: day-name ( n -- string ) day-names nth ;
 
 CONSTANT: day-abbreviations2
     { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
@@ -317,6 +321,9 @@ GENERIC: time- ( time1 time2 -- time3 )
 M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
 
+: same-day? ( ts1 ts2 -- ? )
+    [ >gmt >date< <date> ] bi@ = ;
+
 : (time-) ( timestamp timestamp -- n )
     [ >gmt ] bi@
     [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
@@ -399,6 +406,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-week ( timestamp -- n )
     >date< zeller-congruence ;
 
+GENERIC: day-name ( obj -- string )
+M: integer day-name day-names nth ;
+M: timestamp day-name day-of-week day-names nth ;
+
 :: (day-of-year) ( year month day -- n )
     day-counts month head-slice sum day +
     year leap-year? [
@@ -484,6 +495,14 @@ M: timestamp december clone 12 >>month ;
 : friday ( timestamp -- new-timestamp ) 5 day-this-week ;
 : saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
 
+: sunday? ( timestamp -- ? ) day-of-week 0 = ;
+: monday? ( timestamp -- ? ) day-of-week 1 = ;
+: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
+: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
+: thursday? ( timestamp -- ? ) day-of-week 4 = ;
+: friday? ( timestamp -- ? ) day-of-week 5 = ;
+: saturday? ( timestamp -- ? ) day-of-week 6 = ;
+
 : sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
 : monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
 : tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;

basis/cpu/ppc/ppc.factor

@@ -256,35 +256,22 @@ M: ppc %double>single-float FRSP ;
 M: ppc %unbox-alien ( dst src -- )
     alien-offset LWZ ;
 
-M:: ppc %unbox-any-c-ptr ( dst src temp -- )
+M:: ppc %unbox-any-c-ptr ( dst src -- )
     [
-        { "is-byte-array" "end" "start" } [ define-label ] each
+        "end" define-label
-        ! Address is computed in dst
         0 dst LI
-        ! Load object into scratch-reg
-        scratch-reg src MR
-        ! We come back here with displaced aliens
-        "start" resolve-label
         ! Is the object f?
-        0 scratch-reg \ f type-number CMPI
+        0 src \ f type-number CMPI
-        ! If so, done
         "end" get BEQ
+        ! Compute tag in dst register
+        dst src tag-mask get ANDI
         ! Is the object an alien?
-        0 scratch-reg header-offset LWZ
+        0 dst alien type-number CMPI
-        0 0 alien type-number tag-fixnum CMPI
+        ! Add an offset to start of byte array's data
-        "is-byte-array" get BNE
+        dst src byte-array-offset ADDI
-        ! If so, load the offset
+        "end" get BNE
-        0 scratch-reg alien-offset LWZ
+        ! If so, load the offset and add it to the address
-        ! Add it to address being computed
+        dst src alien-offset LWZ
-        dst dst 0 ADD
-        ! Now recurse on the underlying alien
-        scratch-reg scratch-reg underlying-alien-offset LWZ
-        "start" get B
-        "is-byte-array" resolve-label
-        ! Add byte array address to address being computed
-        dst dst scratch-reg ADD
-        ! Add an offset to start of byte array's data area
-        dst dst byte-array-offset ADDI
         "end" resolve-label
     ] with-scope ;
 
@@ -293,53 +280,84 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
 M:: ppc %box-alien ( dst src temp -- )
     [
         "f" define-label
-        dst  %load-immediate
+        dst \ f type-number %load-immediate
         0 src 0 CMPI
         "f" get BEQ
         dst 5 cells alien temp %allot
         temp \ f type-number %load-immediate
         temp dst 1 alien@ STW
         temp dst 2 alien@ STW
-        displacement dst 3 alien@ STW
+        src dst 3 alien@ STW
-        displacement dst 4 alien@ STW
+        src dst 4 alien@ STW
         "f" resolve-label
     ] with-scope ;
 
-M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
+    ! This is ridiculous
     [
         "end" define-label
-        "alloc" define-label
+        "not-f" define-label
-        "simple-case" define-label
+        "not-alien" define-label
+
         ! If displacement is zero, return the base
         dst base MR
         0 displacement 0 CMPI
         "end" get BEQ
-        ! Quickly use displacement' before its needed for real, as allot temporary
+
-        displacement' :> temp
+        ! Displacement is non-zero, we're going to be allocating a new
-        dst 4 cells alien temp %allot
+        ! object
-        ! If base is already a displaced alien, unpack it
+        dst 5 cells alien temp %allot
-        0 base \ f type-number CMPI
+
-        "simple-case" get BEQ
+        ! Set expired to f
-        temp base header-offset LWZ
-        0 temp alien type-number tag-fixnum CMPI
-        "simple-case" get BNE
-        ! displacement += base.displacement
-        temp base 3 alien@ LWZ
-        displacement' displacement temp ADD
-        ! base = base.base
-        base' base 1 alien@ LWZ
-        "alloc" get B
-        "simple-case" resolve-label
-        displacement' displacement MR
-        base' base MR
-        "alloc" resolve-label
-        ! Store underlying-alien slot
-        base' dst 1 alien@ STW
-        ! Store offset
-        displacement' dst 3 alien@ STW
-        ! Store expired slot (its ok to clobber displacement')
         temp \ f type-number %load-immediate
         temp dst 2 alien@ STW
+
+        ! Is base f?
+        0 base \ f type-number CMPI
+        "not-f" get BNE
+
+        ! Yes, it is f. Fill in new object
+        base dst 1 alien@ STW
+        displacement dst 3 alien@ STW
+        displacement dst 4 alien@ STW
+
+        "end" get B
+
+        "not-f" resolve-label
+
+        ! Check base type
+        temp base tag-mask get ANDI
+
+        ! Is base an alien?
+        0 temp alien type-number CMPI
+        "not-alien" get BNE
+
+        ! Yes, it is an alien. Set new alien's base to base.base
+        temp base 1 alien@ LWZ
+        temp dst 1 alien@ STW
+
+        ! Compute displacement
+        temp base 3 alien@ LWZ
+        temp temp displacement ADD
+        temp dst 3 alien@ STW
+
+        ! Compute address
+        temp base 4 alien@ LWZ
+        temp temp displacement ADD
+        temp dst 4 alien@ STW
+
+        ! We are done
+        "end" get B
+
+        ! Is base a byte array? It has to be, by now...
+        "not-alien" resolve-label
+
+        base dst 1 alien@ STW
+        displacement dst 3 alien@ STW
+        temp base byte-array-offset ADDI
+        temp temp displacement ADD
+        temp dst 4 alien@ STW
+
         "end" resolve-label
     ] with-scope ;
 

basis/prettyprint/backend/backend.factor

@@ -116,8 +116,7 @@ M: pathname pprint*
 : check-recursion ( obj quot -- )
     nesting-limit? [
         drop
-        "~" over class name>> "~" 3append
+        [ class name>> "~" dup surround ] keep present-text 
-        swap present-text
     ] [
         over recursion-check get member-eq? [
             drop "~circularity~" swap present-text
@@ -175,7 +174,7 @@ M: tuple pprint*
 : pprint-elements ( seq -- )
     do-length-limit
     [ [ pprint* ] each ] dip
-    [ "~" swap number>string " more~" 3append text ] when* ;
+    [ number>string "~" " more~" surround text ] when* ;
 
 M: quotation pprint-delims drop \ [ \ ] ;
 M: curry pprint-delims drop \ [ \ ] ;

basis/xml/entities/html/html.factor

@@ -11,8 +11,8 @@ VALUE: html-entities
 
 : get-html ( -- table )
     { "lat1" "special" "symbol" } [
-        "vocab:xml/entities/html/xhtml-"
+        "vocab:xml/entities/html/xhtml-" ".ent" surround
-        swap ".ent" 3append read-entities-file
+        read-entities-file
     ] map first3 assoc-union assoc-union ;
 
 get-html to: html-entities

core/bootstrap/primitives.factor

@@ -16,7 +16,7 @@ H{ } clone sub-primitives set
 
 "vocab:bootstrap/syntax.factor" parse-file
 
-"vocab:cpu/" architecture get {
+architecture get {
     { "x86.32" "x86/32" }
     { "winnt-x86.64" "x86/64/winnt" }
     { "unix-x86.64" "x86/64/unix" }
@@ -24,7 +24,7 @@ H{ } clone sub-primitives set
     { "macosx-ppc" "ppc/macosx" }
     { "arm" "arm" }
 } ?at [ "Bad architecture: " prepend throw ] unless
-"/bootstrap.factor" 3append parse-file
+"vocab:cpu/" "/bootstrap.factor" surround parse-file
 
 "vocab:bootstrap/layouts/layouts.factor" parse-file
 

core/io/pathnames/pathnames.factor

@@ -102,8 +102,8 @@ PRIVATE>
             [ 2 head ] dip append
         ] }
         [
-            [ trim-tail-separators "/" ] dip
+            [ trim-tail-separators ]
-            trim-head-separators 3append
+            [ trim-head-separators ] bi* "/" glue
         ]
     } cond ;
 

extra/calendar/holidays/us/us.factor

@@ -1,130 +1,143 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar kernel math words ;
+USING: accessors assocs calendar combinators.short-circuit fry
+kernel lexer math namespaces parser sequences shuffle vocabs
+words ;
 IN: calendar.holidays.us
 
+SYMBOLS: world us us-federal canada
+commonwealth-of-nations ;
+
 <<
-SYNTAX: us-federal
+SYNTAX: HOLIDAY:
-    word "us-federal" dup set-word-prop ;
+    CREATE-WORD
+    dup H{ } clone "holiday" set-word-prop
+    parse-definition (( timestamp/n -- timestamp )) define-declared ;
+
+SYNTAX: HOLIDAY-NAME:
+    scan-word "holiday" word-prop scan-word scan-object spin set-at ;
 >>
 
-! Federal Holidays
+: holiday>timestamp ( n word -- timestamp )
-: new-years-day ( timestamp/n -- timestamp )
+    execute( timestamp -- timestamp' ) ;
-    january 1 >>day ; us-federal
 
-: martin-luther-king-day ( timestamp/n -- timestamp )
+: find-holidays ( n symbol -- seq )
-    january 3 monday-of-month ; us-federal
+    all-words swap '[ "holiday" word-prop _ swap key? ] filter
+    [ holiday>timestamp ] with map ;
 
-: inauguration-day ( timestamp/n -- timestamp )
+: adjust-federal-holiday ( timestamp -- timestamp' )
-    year dup neg 4 rem + january 20 >>day ; us-federal
+    dup saturday? [
+        1 days time-
+    ] [
+        dup sunday? [
+            1 days time+
+        ] when 
+    ] if ;
 
-: washington's-birthday ( timestamp/n -- timestamp )
+: us-federal-holidays ( timestamp/n -- seq )
-    february 3 monday-of-month ; us-federal
+    us-federal find-holidays [ adjust-federal-holiday ] map ;
 
-ALIAS: presidents-day washington's-birthday us-federal
+: us-federal-holiday? ( timestamp/n -- ? )
+    dup us-federal-holidays [ same-day? ] with any? ;
 
-: memorial-day ( timestamp/n -- timestamp )
+: canadian-holidays ( timestamp/n -- seq )
-    may last-monday-of-month ; us-federal
+    canada find-holidays ;
 
-: independence-day ( timestamp/n -- timestamp )
+: post-office-open? ( timestamp -- ? )
-    july 4 >>day ; us-federal
+    { [ sunday? not ] [ us-federal-holiday? not ] } 1&& ;
 
-: labor-day ( timestamp/n -- timestamp )
+HOLIDAY: new-year's-day january 1 >>day ;
-    september 1 monday-of-month ; us-federal
+HOLIDAY-NAME: new-year's-day world "New Year's Day"
+HOLIDAY-NAME: new-year's-day us-federal "New Year's Day"
 
-: columbus-day ( timestamp/n -- timestamp )
+HOLIDAY: martin-luther-king-day january 3 monday-of-month ;
-    october 2 monday-of-month ; us-federal
+HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day"
 
-: veterans'-day ( timestamp/n -- timestamp )
+HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ;
-    november 11 >>day ; us-federal
+HOLIDAY-NAME: inauguration-day us "Inauguration Day"
 
-: thanksgiving-day ( timestamp/n -- timestamp )
+HOLIDAY: washington's-birthday february 3 monday-of-month ;
-    november 4 thursday-of-month ; us-federal
+HOLIDAY-NAME: washington's-birthday us-federal "Washington's Birthday"
 
-: christmas-day ( timestamp/n -- timestamp )
+HOLIDAY: memorial-day may last-monday-of-month ;
-    december 25 >>day ; us-federal
+HOLIDAY-NAME: memorial-day us-federal "Memorial Day"
 
-! Other Holidays
+HOLIDAY: independence-day july 4 >>day ;
+HOLIDAY-NAME: independence-day us-federal "Independence Day"
 
-: belly-laugh-day ( timestamp/n -- timestamp )
+HOLIDAY: labor-day september 1 monday-of-month ;
-    january 24 >>day ;
+HOLIDAY-NAME: labor-day us-federal "Labor Day"
 
-: groundhog-day ( timestamp/n -- timestamp )
+HOLIDAY: columbus-day october 2 monday-of-month ;
-    february 2 >>day ;
+HOLIDAY-NAME: columbus-day us-federal "Columbus Day"
 
-: lincoln's-birthday ( timestamp/n -- timestamp )
+HOLIDAY: veterans-day november 11 >>day ;
-    february 12 >>day ;
+HOLIDAY-NAME: veterans-day us-federal "Veterans Day"
+HOLIDAY-NAME: veterans-day world "Armistice Day"
+HOLIDAY-NAME: veterans-day commonwealth-of-nations "Remembrance Day"
 
-: valentine's-day ( timestamp/n -- timestamp )
+HOLIDAY: thanksgiving-day november 4 thursday-of-month ;
-    february 14 >>day ;
+HOLIDAY-NAME: thanksgiving-day us-federal "Thanksgiving Day"
 
-: st-patrick's-day ( timestamp/n -- timestamp )
+HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ;
-    march 17 >>day ;
+HOLIDAY-NAME: canadian-thanksgiving-day canada "Thanksgiving Day"
 
-: ash-wednesday ( timestamp/n -- timestamp )
+HOLIDAY: christmas-day december 25 >>day ;
-    easter 46 days time- ;
+HOLIDAY-NAME: christmas-day world "Christmas Day"
+HOLIDAY-NAME: christmas-day us-federal "Christmas Day"
+
+HOLIDAY: belly-laugh-day january 24 >>day ;
+
+HOLIDAY: groundhog-day february 2 >>day ;
+
+HOLIDAY: lincoln's-birthday february 12 >>day ;
+
+HOLIDAY: valentine's-day february 14 >>day ;
+
+HOLIDAY: st-patrick's-day march 17 >>day ;
+
+HOLIDAY: ash-wednesday easter 46 days time- ;
 
 ALIAS: first-day-of-lent ash-wednesday
 
-: fat-tuesday ( timestamp/n -- timestamp )
+HOLIDAY: fat-tuesday ash-wednesday 1 days time- ;
-    ash-wednesday 1 days time- ;
 
-: good-friday ( timestamp/n -- timestamp )
+HOLIDAY: good-friday easter 2 days time- ;
-    easter 2 days time- ;
 
-: tax-day ( timestamp/n -- timestamp )
+HOLIDAY: tax-day april 15 >>day ;
-    april 15 >>day ;
 
-: earth-day ( timestamp/n -- timestamp )
+HOLIDAY: earth-day april 22 >>day ;
-    april 22 >>day ;
 
-: administrative-professionals'-day ( timestamp/n -- timestamp )
+HOLIDAY: administrative-professionals'-day april last-saturday-of-month wednesday ;
-    april last-saturday-of-month wednesday ;
 
-: cinco-de-mayo ( timestamp/n -- timestamp )
+HOLIDAY: cinco-de-mayo may 5 >>day ;
-    may 5 >>day ;
 
-: mother's-day ( timestamp/n -- timestamp )
+HOLIDAY: mother's-day may 2 sunday-of-month ;
-    may 2 sunday-of-month ;
 
-: armed-forces-day ( timestamp/n -- timestamp )
+HOLIDAY: armed-forces-day may 3 saturday-of-month ;
-    may 3 saturday-of-month ;
 
-: flag-day ( timestamp/n -- timestamp )
+HOLIDAY: flag-day june 14 >>day ;
-    june 14 >>day ;
 
-: parents'-day ( timestamp/n -- timestamp )
+HOLIDAY: parents'-day july 4 sunday-of-month ;
-    july 4 sunday-of-month ;
 
-: grandparents'-day ( timestamp/n -- timestamp )
+HOLIDAY: grandparents'-day labor-day 1 weeks time+ ;
-    labor-day 1 weeks time+ ;
 
-: patriot-day ( timestamp/n -- timestamp )
+HOLIDAY: patriot-day september 11 >>day ;
-    september 11 >>day ;
 
-: stepfamily-day ( timestamp/n -- timestamp )
+HOLIDAY: stepfamily-day september 16 >>day ;
-    september 16 >>day ;
 
-: citizenship-day ( timestamp/n -- timestamp )
+HOLIDAY: citizenship-day september 17 >>day ;
-    september 17 >>day ;
 
-: boss's-day ( timestamp/n -- timestamp )
+HOLIDAY: boss's-day october 16 >>day ;
-    october 16 >>day ;
 
-: sweetest-day ( timestamp/n -- timestamp )
+HOLIDAY: sweetest-day october 3 saturday-of-month ;
-    october 3 saturday-of-month ;
 
-: halloween ( timestamp/n -- timestamp )
+HOLIDAY: halloween october 31 >>day ;
-    october 31 >>day ;
 
-: election-day ( timestamp/n -- timestamp )
+HOLIDAY: election-day november 1 monday-of-month 1 days time+ ;
-    november 1 monday-of-month 1 days time+ ;
 
-: black-friday ( timestamp/n -- timestamp )
+HOLIDAY: black-friday thanksgiving-day 1 days time+ ;
-    thanksgiving-day 1 days time+ ;
 
-: pearl-harbor-remembrance-day ( timestamp/n -- timestamp )
+HOLIDAY: pearl-harbor-remembrance-day december 7 >>day ;
-    december 7 >>day ;
 
-: new-year's-eve ( timestamp/n -- timestamp )
+HOLIDAY: new-year's-eve december 31 >>day ;
-    december 31 >>day ;

extra/irc/client/internals/internals.factor

@@ -26,7 +26,7 @@ IN: irc.client.internals
     irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
 
 : /JOIN ( channel password -- )
-    [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+    [ " :" glue ] when* "JOIN " prepend irc-print ;
 
 : try-connect ( -- stream/f )
     irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;

extra/mason/platform/platform.factor

@@ -17,4 +17,4 @@ IN: mason.platform
     target-os get target-cpu get arch ;
 
 : boot-image-name ( -- string )
-    "boot." boot-image-arch ".image" 3append ;
+    boot-image-arch "boot." ".image" surround ;