diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 83178871f0..e784398baf 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -51,8 +51,16 @@ CONSTANT: month-names "July" "August" "September" "October" "November" "December" } -: month-name ( n -- string ) - check-month 1 - month-names nth ; + + +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 ) - { - "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" - } ; - -: day-name ( n -- string ) day-names nth ; +CONSTANT: day-names + { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" } 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< ] 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 ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 0fb99374a0..a7eb3bb4a5 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/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 - ! Address is computed in dst + "end" define-label 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 - ! If so, done + 0 src \ f type-number CMPI "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 0 alien type-number tag-fixnum CMPI - "is-byte-array" get BNE - ! If so, load the offset - 0 scratch-reg alien-offset LWZ - ! Add it to address being computed - 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 + 0 dst alien type-number CMPI + ! Add an offset to start of byte array's data + dst src byte-array-offset ADDI + "end" get BNE + ! If so, load the offset and add it to the address + dst src alien-offset LWZ "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 - displacement dst 4 alien@ STW + src dst 3 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 - "simple-case" define-label + "not-f" 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 - dst 4 cells alien temp %allot - ! If base is already a displaced alien, unpack it - 0 base \ f type-number CMPI - "simple-case" get BEQ - 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') + + ! Displacement is non-zero, we're going to be allocating a new + ! object + dst 5 cells alien temp %allot + + ! Set expired to f 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 ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 0ba1d38ae6..04617a6c67 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -116,8 +116,7 @@ M: pathname pprint* : check-recursion ( obj quot -- ) nesting-limit? [ drop - "~" over class name>> "~" 3append - swap present-text + [ class name>> "~" dup surround ] keep 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 \ [ \ ] ; diff --git a/basis/xml/entities/html/html.factor b/basis/xml/entities/html/html.factor index 04c0b66063..fd8480307a 100644 --- a/basis/xml/entities/html/html.factor +++ b/basis/xml/entities/html/html.factor @@ -11,8 +11,8 @@ VALUE: html-entities : get-html ( -- table ) { "lat1" "special" "symbol" } [ - "vocab:xml/entities/html/xhtml-" - swap ".ent" 3append read-entities-file + "vocab:xml/entities/html/xhtml-" ".ent" surround + read-entities-file ] map first3 assoc-union assoc-union ; get-html to: html-entities diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8b4c0a4a36..97c66530a0 100644 --- a/core/bootstrap/primitives.factor +++ b/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 diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 25eefd1105..b307128efb 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -102,8 +102,8 @@ PRIVATE> [ 2 head ] dip append ] } [ - [ trim-tail-separators "/" ] dip - trim-head-separators 3append + [ trim-tail-separators ] + [ trim-head-separators ] bi* "/" glue ] } cond ; diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor index 7b3a7ea570..47590e3b16 100644 --- a/extra/calendar/holidays/us/us.factor +++ b/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 - word "us-federal" dup set-word-prop ; +SYNTAX: HOLIDAY: + 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 -: new-years-day ( timestamp/n -- timestamp ) - january 1 >>day ; us-federal +: holiday>timestamp ( n word -- timestamp ) + execute( timestamp -- timestamp' ) ; -: martin-luther-king-day ( timestamp/n -- timestamp ) - january 3 monday-of-month ; us-federal +: find-holidays ( n symbol -- seq ) + all-words swap '[ "holiday" word-prop _ swap key? ] filter + [ holiday>timestamp ] with map ; -: inauguration-day ( timestamp/n -- timestamp ) - year dup neg 4 rem + january 20 >>day ; us-federal +: adjust-federal-holiday ( timestamp -- timestamp' ) + dup saturday? [ + 1 days time- + ] [ + dup sunday? [ + 1 days time+ + ] when + ] if ; -: washington's-birthday ( timestamp/n -- timestamp ) - february 3 monday-of-month ; us-federal +: us-federal-holidays ( timestamp/n -- seq ) + 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 ) - may last-monday-of-month ; us-federal +: canadian-holidays ( timestamp/n -- seq ) + canada find-holidays ; -: independence-day ( timestamp/n -- timestamp ) - july 4 >>day ; us-federal +: post-office-open? ( timestamp -- ? ) + { [ sunday? not ] [ us-federal-holiday? not ] } 1&& ; -: labor-day ( timestamp/n -- timestamp ) - september 1 monday-of-month ; us-federal +HOLIDAY: new-year's-day january 1 >>day ; +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 ) - october 2 monday-of-month ; us-federal +HOLIDAY: martin-luther-king-day january 3 monday-of-month ; +HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day" -: veterans'-day ( timestamp/n -- timestamp ) - november 11 >>day ; us-federal +HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ; +HOLIDAY-NAME: inauguration-day us "Inauguration Day" -: thanksgiving-day ( timestamp/n -- timestamp ) - november 4 thursday-of-month ; us-federal +HOLIDAY: washington's-birthday february 3 monday-of-month ; +HOLIDAY-NAME: washington's-birthday us-federal "Washington's Birthday" -: christmas-day ( timestamp/n -- timestamp ) - december 25 >>day ; us-federal +HOLIDAY: memorial-day may last-monday-of-month ; +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 ) - january 24 >>day ; +HOLIDAY: labor-day september 1 monday-of-month ; +HOLIDAY-NAME: labor-day us-federal "Labor Day" -: groundhog-day ( timestamp/n -- timestamp ) - february 2 >>day ; +HOLIDAY: columbus-day october 2 monday-of-month ; +HOLIDAY-NAME: columbus-day us-federal "Columbus Day" -: lincoln's-birthday ( timestamp/n -- timestamp ) - february 12 >>day ; +HOLIDAY: veterans-day november 11 >>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 ) - february 14 >>day ; +HOLIDAY: thanksgiving-day november 4 thursday-of-month ; +HOLIDAY-NAME: thanksgiving-day us-federal "Thanksgiving Day" -: st-patrick's-day ( timestamp/n -- timestamp ) - march 17 >>day ; +HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ; +HOLIDAY-NAME: canadian-thanksgiving-day canada "Thanksgiving Day" -: ash-wednesday ( timestamp/n -- timestamp ) - easter 46 days time- ; +HOLIDAY: christmas-day december 25 >>day ; +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 ) - ash-wednesday 1 days time- ; +HOLIDAY: fat-tuesday ash-wednesday 1 days time- ; -: good-friday ( timestamp/n -- timestamp ) - easter 2 days time- ; +HOLIDAY: good-friday easter 2 days time- ; -: tax-day ( timestamp/n -- timestamp ) - april 15 >>day ; +HOLIDAY: tax-day april 15 >>day ; -: earth-day ( timestamp/n -- timestamp ) - april 22 >>day ; +HOLIDAY: earth-day april 22 >>day ; -: administrative-professionals'-day ( timestamp/n -- timestamp ) - april last-saturday-of-month wednesday ; +HOLIDAY: administrative-professionals'-day april last-saturday-of-month wednesday ; -: cinco-de-mayo ( timestamp/n -- timestamp ) - may 5 >>day ; +HOLIDAY: cinco-de-mayo may 5 >>day ; -: mother's-day ( timestamp/n -- timestamp ) - may 2 sunday-of-month ; +HOLIDAY: mother's-day may 2 sunday-of-month ; -: armed-forces-day ( timestamp/n -- timestamp ) - may 3 saturday-of-month ; +HOLIDAY: armed-forces-day may 3 saturday-of-month ; -: flag-day ( timestamp/n -- timestamp ) - june 14 >>day ; +HOLIDAY: flag-day june 14 >>day ; -: parents'-day ( timestamp/n -- timestamp ) - july 4 sunday-of-month ; +HOLIDAY: parents'-day july 4 sunday-of-month ; -: grandparents'-day ( timestamp/n -- timestamp ) - labor-day 1 weeks time+ ; +HOLIDAY: grandparents'-day labor-day 1 weeks time+ ; -: patriot-day ( timestamp/n -- timestamp ) - september 11 >>day ; +HOLIDAY: patriot-day september 11 >>day ; -: stepfamily-day ( timestamp/n -- timestamp ) - september 16 >>day ; +HOLIDAY: stepfamily-day september 16 >>day ; -: citizenship-day ( timestamp/n -- timestamp ) - september 17 >>day ; +HOLIDAY: citizenship-day september 17 >>day ; -: boss's-day ( timestamp/n -- timestamp ) - october 16 >>day ; +HOLIDAY: boss's-day october 16 >>day ; -: sweetest-day ( timestamp/n -- timestamp ) - october 3 saturday-of-month ; +HOLIDAY: sweetest-day october 3 saturday-of-month ; -: halloween ( timestamp/n -- timestamp ) - october 31 >>day ; +HOLIDAY: halloween october 31 >>day ; -: election-day ( timestamp/n -- timestamp ) - november 1 monday-of-month 1 days time+ ; +HOLIDAY: election-day november 1 monday-of-month 1 days time+ ; -: black-friday ( timestamp/n -- timestamp ) - thanksgiving-day 1 days time+ ; +HOLIDAY: black-friday thanksgiving-day 1 days time+ ; -: pearl-harbor-remembrance-day ( timestamp/n -- timestamp ) - december 7 >>day ; +HOLIDAY: pearl-harbor-remembrance-day december 7 >>day ; -: new-year's-eve ( timestamp/n -- timestamp ) - december 31 >>day ; +HOLIDAY: new-year's-eve december 31 >>day ; diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index ef1695f563..f2030e87b0 100644 --- a/extra/irc/client/internals/internals.factor +++ b/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 ; diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index d6be8654c5..2a33c5240b 100644 --- a/extra/mason/platform/platform.factor +++ b/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 ;