swap append to swap append
refactoring path+ to append-path swap path+ to prepend-path calendar gmt-offset to durationdb4
Doug Coleman
parent
1802e7c443
commit
3e7940216e
|
|
@ -135,18 +135,18 @@ SYMBOL: end
|
|||
GENERIC: >ber ( obj -- byte-array )
|
||||
M: fixnum >ber ( n -- byte-array )
|
||||
>128-ber dup length 2 swap 2array
|
||||
"cc" pack-native swap append ;
|
||||
"cc" pack-native prepend ;
|
||||
|
||||
: >ber-enumerated ( n -- byte-array )
|
||||
>128-ber >byte-array dup length 10 swap 2array
|
||||
"CC" pack-native swap append ;
|
||||
"CC" pack-native prepend ;
|
||||
|
||||
: >ber-length-encoding ( n -- byte-array )
|
||||
dup 127 <= [
|
||||
1array "C" pack-be
|
||||
] [
|
||||
1array "I" pack-be 0 swap remove dup length
|
||||
HEX: 80 + 1array "C" pack-be swap append
|
||||
HEX: 80 + 1array "C" pack-be prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array )
|
|||
dup 126 > [
|
||||
"range error in bignum" throw
|
||||
] [
|
||||
2 swap 2array "CC" pack-native swap append
|
||||
2 swap 2array "CC" pack-native prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
|||
|
||||
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
|
||||
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
||||
|
||||
: wrap-line ( a-line-z -- za-line-za )
|
||||
dup peek 1array swap dup first 1array append append ;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
|||
>r keys r> define-slots ;
|
||||
|
||||
: define-setters ( classname slots -- )
|
||||
>r "with-" swap append r>
|
||||
>r "with-" prepend r>
|
||||
dup values [setters]
|
||||
>r keys r> define-slots ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ bootstrap.image sequences io ;
|
|||
: download-image ( arch -- )
|
||||
boot-image-name dup need-new-image? [
|
||||
"Downloading " write dup write "..." print
|
||||
url swap append download
|
||||
url prepend download
|
||||
] [
|
||||
"Boot image up to date" print
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel vocabs vocabs.loader sequences system ;
|
||||
|
||||
{ "ui" "help" "tools" }
|
||||
[ "bootstrap." swap append vocab ] all? [
|
||||
[ "bootstrap." prepend vocab ] all? [
|
||||
"ui.tools" require
|
||||
|
||||
"ui.cocoa" vocab [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ vocabs vocabs.loader ;
|
|||
{ [ windows? ] [ "windows" ] }
|
||||
{ [ unix? ] [ "x11" ] }
|
||||
} cond
|
||||
] unless* "ui." swap append require
|
||||
] unless* "ui." prepend require
|
||||
|
||||
"ui.freetype" require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -58,8 +58,8 @@ IN: builder
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: copy-image ( -- )
|
||||
builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
|
||||
builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
|
||||
builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
|
||||
builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: builder.release
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: releases ( -- path )
|
||||
builds "releases" path+
|
||||
builds "releases" append-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ USING: kernel ;
|
|||
IN: calendar.backend
|
||||
|
||||
SYMBOL: calendar-backend
|
||||
HOOK: gmt-offset calendar-backend
|
||||
HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test
|
|||
continuations system ;
|
||||
IN: calendar.tests
|
||||
|
||||
[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ t ] [ now valid-timestamp? ] unit-test
|
||||
|
||||
[ f ] [ 1900 leap-year? ] unit-test
|
||||
|
|
@ -18,126 +18,126 @@ IN: calendar.tests
|
|||
[ f ] [ 2001 leap-year? ] unit-test
|
||||
[ f ] [ 2006 leap-year? ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
|
||||
[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
|
||||
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
|
||||
[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
|
||||
2004 1 1 11 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
|
||||
2004 1 1 16 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
|
||||
2004 1 1 13 30 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
|
||||
[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,20 +3,23 @@
|
|||
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings tuples system vocabs.loader calendar.backend threads
|
||||
new-slots accessors combinators ;
|
||||
new-slots accessors combinators locals ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset <timestamp> ;
|
||||
|
||||
TUPLE: duration year month day hour minute second ;
|
||||
|
||||
C: <duration> duration
|
||||
|
||||
: gmt-offset-duration ( -- duration )
|
||||
0 0 0 gmt-offset <duration> ;
|
||||
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset-duration <timestamp> ;
|
||||
|
||||
: month-names
|
||||
{
|
||||
"Not a month" "January" "February" "March" "April" "May" "June"
|
||||
|
|
@ -226,16 +229,18 @@ M: duration <=> [ dt>years ] compare ;
|
|||
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
|
||||
: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
|
||||
|
||||
: convert-timezone ( timestamp n -- timestamp )
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
|
||||
: convert-timezone ( timestamp duration -- timestamp )
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
[ over gmt-offset>> - hours time+ ] keep >>gmt-offset
|
||||
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
|
||||
] if ;
|
||||
|
||||
: >local-time ( timestamp -- timestamp )
|
||||
gmt-offset convert-timezone ;
|
||||
gmt-offset-duration convert-timezone ;
|
||||
|
||||
: >gmt ( timestamp -- timestamp )
|
||||
0 convert-timezone ;
|
||||
instant convert-timezone ;
|
||||
|
||||
M: timestamp <=> ( ts1 ts2 -- n )
|
||||
[ >gmt tuple-slots ] compare ;
|
||||
|
|
@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
|
||||
M: timestamp time-
|
||||
#! Exact calendar-time difference
|
||||
(time-) seconds ;
|
||||
|
|
@ -263,14 +266,14 @@ M: timestamp time-
|
|||
M: duration time-
|
||||
before time+ ;
|
||||
|
||||
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
|
||||
: <zero> 0 0 0 0 0 0 instant <timestamp> ;
|
||||
|
||||
: valid-timestamp? ( timestamp -- ? )
|
||||
clone 0 >>gmt-offset
|
||||
clone instant >>gmt-offset
|
||||
dup <zero> time- <zero> time+ = ;
|
||||
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ; foldable
|
||||
1970 1 1 0 0 0 instant <timestamp> ; foldable
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: calendar.format calendar kernel tools.test
|
||||
io.streams.string ;
|
||||
IN: calendar.format.tests
|
||||
USING: calendar.format tools.test io.streams.string ;
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
|
|
@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ;
|
|||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ ] [ now timestamp>rfc3339 drop ] unit-test
|
||||
[ ] [ now timestamp>rfc822 drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: calendar.format
|
||||
USING: math math.parser kernel sequences io calendar
|
||||
accessors arrays io.streams.string combinators accessors ;
|
||||
accessors arrays io.streams.string combinators accessors
|
||||
combinators.cleave ;
|
||||
IN: calendar.format
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
|
|
@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- )
|
|||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
: (write-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
{
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
|
||||
dup instant <=> {
|
||||
{ [ dup 0 = ] [ 2drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
: timestamp>rfc822 ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
|
|
@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- )
|
|||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
>gmt timestamp>rfc822 ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
: (write-rfc3339-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 CHAR: : write1 ]
|
||||
[ minute>> write-00 ] bi ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( duration -- )
|
||||
dup instant <=> {
|
||||
{ [ dup 0 = ] [ 2drop "Z" write ] }
|
||||
{ [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup year>> number>string write CHAR: - write1
|
||||
dup month>> write-00 CHAR: - write1
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
USING: alien alien.c-types arrays calendar.backend
|
||||
kernel structs math unix.time namespaces ;
|
||||
kernel structs math unix.time namespaces ;
|
||||
|
||||
IN: calendar.unix
|
||||
|
||||
|
|
@ -8,11 +7,11 @@ TUPLE: unix-calendar ;
|
|||
|
||||
T{ unix-calendar } calendar-backend set-global
|
||||
|
||||
: get-time
|
||||
: get-time ( -- alien )
|
||||
f time <uint> localtime ;
|
||||
|
||||
: timezone-name
|
||||
: timezone-name ( -- string )
|
||||
get-time tm-zone ;
|
||||
|
||||
M: unix-calendar gmt-offset
|
||||
get-time tm-gmtoff 3600 / ;
|
||||
M: unix-calendar gmt-offset ( -- hours minutes seconds )
|
||||
get-time tm-gmtoff 3600 /mod 60 /mod ;
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at
|
|||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get at
|
||||
[ ] [ "No such method: " swap append throw ] ?if ;
|
||||
[ ] [ "No such method: " prepend throw ] ?if ;
|
||||
|
||||
: make-dip ( quot n -- quot' )
|
||||
dup
|
||||
|
|
@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot )
|
|||
! Runtime introspection
|
||||
: (objc-class) ( string word -- class )
|
||||
dupd execute
|
||||
[ ] [ "No such class: " swap append throw ] ?if ; inline
|
||||
[ ] [ "No such class: " prepend throw ] ?if ; inline
|
||||
|
||||
: objc-class ( string -- class )
|
||||
\ objc_getClass (objc-class) ;
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ MACRO: spread ( seq -- )
|
|||
dup
|
||||
[ drop [ >r ] ] map concat
|
||||
swap
|
||||
[ [ r> ] swap append ] map concat
|
||||
[ [ r> ] prepend ] map concat
|
||||
append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -75,11 +75,11 @@ MACRO: && ( quots -- ? )
|
|||
[ [ not ] append [ f ] ] t short-circuit ;
|
||||
|
||||
MACRO: <-&& ( quots -- )
|
||||
[ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ nip ] append ;
|
||||
|
||||
MACRO: <--&& ( quots -- )
|
||||
[ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
|
||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
|
@ -130,12 +130,12 @@ MACRO: map-call-with ( quots -- )
|
|||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
|
||||
: (make-call-with2) ( quots -- quot )
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
|
||||
MACRO: map-call-with2 ( quots -- )
|
||||
[
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
|
||||
[ 2drop ] append
|
||||
] keep length [ narray ] curry append ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
|
|||
dup <CFBundle> [
|
||||
CFBundleLoadExecutable drop
|
||||
] [
|
||||
"Cannot load bundled named " swap append throw
|
||||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
|
|
|||
|
|
@ -446,7 +446,7 @@ M: cpu reset ( cpu -- )
|
|||
SYMBOL: rom-root
|
||||
|
||||
: rom-dir ( -- string )
|
||||
rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
|
||||
rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
|
||||
|
||||
: load-rom* ( seq cpu -- )
|
||||
#! 'seq' is an array of arrays. Each array contains
|
||||
|
|
@ -455,7 +455,7 @@ SYMBOL: rom-root
|
|||
#! file path shoul dbe relative to the '/roms' resource path.
|
||||
rom-dir [
|
||||
cpu-ram [
|
||||
swap first2 rom-dir swap path+ binary [
|
||||
swap first2 rom-dir prepend-path binary [
|
||||
swap (load-rom)
|
||||
] with-file-reader
|
||||
] curry each
|
||||
|
|
@ -1027,14 +1027,14 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADC-R,(RR)-instruction ( -- parser )
|
||||
"ADC-R,(RR)" "ADC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SBC-R,N-instruction ( -- parser )
|
||||
"SBC-R,N" "SBC" complex-instruction
|
||||
|
|
@ -1047,14 +1047,14 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SBC-R,(RR)-instruction ( -- parser )
|
||||
"SBC-R,(RR)" "SBC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SUB-R-instruction ( -- parser )
|
||||
"SUB-R" "SUB" complex-instruction
|
||||
|
|
@ -1082,21 +1082,21 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADD-RR,RR-instruction ( -- parser )
|
||||
"ADD-RR,RR" "ADD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADD-R,(RR)-instruction ( -- parser )
|
||||
"ADD-R,(RR)" "ADD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,NN-instruction
|
||||
#! LD BC,nn
|
||||
|
|
@ -1124,28 +1124,28 @@ SYMBOL: $4
|
|||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,R-instruction
|
||||
"LD-R,R" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,RR-instruction
|
||||
"LD-RR,RR" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,(RR)-instruction
|
||||
"LD-R,(RR)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-(NN),RR-instruction
|
||||
"LD-(NN),RR" "LD" complex-instruction
|
||||
|
|
@ -1194,14 +1194,14 @@ SYMBOL: $4
|
|||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: EX-RR,RR-instruction
|
||||
"EX-RR,RR" "EX" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: 8080-generator-parser
|
||||
NOP-instruction
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
|
|||
[
|
||||
statement-in-params
|
||||
[
|
||||
[ sql-spec-column-name ":" swap append ]
|
||||
[ sql-spec-column-name ":" prepend ]
|
||||
[ sql-spec-slot-name rot get-slot-named ]
|
||||
[ sql-spec-type ] tri 3array
|
||||
] with map
|
||||
|
|
@ -173,7 +173,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
|
|||
! : select-sequence ( seq name -- ) ;
|
||||
|
||||
M: sqlite-db bind% ( spec -- )
|
||||
dup 1, sql-spec-column-name ":" swap append 0% ;
|
||||
dup 1, sql-spec-column-name ":" prepend 0% ;
|
||||
|
||||
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ TUPLE: no-sql-modifier ;
|
|||
: modifiers ( spec -- str )
|
||||
sql-spec-modifiers
|
||||
[ lookup-modifier ] map " " join
|
||||
dup empty? [ " " swap append ] unless ;
|
||||
dup empty? [ " " prepend ] unless ;
|
||||
|
||||
HOOK: bind% db ( spec -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ TUPLE: document locs ;
|
|||
0 swap [ append ] change-nth ;
|
||||
|
||||
: append-last ( str seq -- )
|
||||
[ length 1- ] keep [ swap append ] change-nth ;
|
||||
[ length 1- ] keep [ prepend ] change-nth ;
|
||||
|
||||
: loc-col/str ( loc document -- str col )
|
||||
>r first2 swap r> nth swap ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: editors.editpadpro
|
|||
|
||||
: editpadpro-path
|
||||
\ editpadpro-path get-global [
|
||||
program-files "JGsoft" path+
|
||||
program-files "JGsoft" append-path
|
||||
t [ >lower "editpadpro.exe" tail? ] find-file
|
||||
] unless* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.editplus
|
|||
|
||||
: editplus-path ( -- path )
|
||||
\ editplus-path get-global [
|
||||
program-files "\\EditPlus 2\\editplus.exe" path+
|
||||
program-files "\\EditPlus 2\\editplus.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: editplus ( file line -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.emeditor
|
|||
|
||||
: emeditor-path ( -- path )
|
||||
\ emeditor-path get-global [
|
||||
program-files "\\EmEditor\\EmEditor.exe" path+
|
||||
program-files "\\EmEditor\\EmEditor.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: emeditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -4,6 +4,6 @@ IN: editors.gvim.windows
|
|||
|
||||
M: windows-io gvim-path
|
||||
\ gvim-path get-global [
|
||||
program-files "vim" path+
|
||||
program-files "vim" append-path
|
||||
t [ "gvim.exe" tail? ] find-file
|
||||
] unless* ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ io.encodings.utf8 ;
|
|||
IN: editors.jedit
|
||||
|
||||
: jedit-server-info ( -- port auth )
|
||||
home "/.jedit/server" path+ ascii [
|
||||
home "/.jedit/server" append-path ascii [
|
||||
readln drop
|
||||
readln string>number
|
||||
readln string>number
|
||||
|
|
@ -32,7 +32,7 @@ IN: editors.jedit
|
|||
] with-stream ;
|
||||
|
||||
: jedit-location ( file line -- )
|
||||
number>string "+line:" swap append 2array
|
||||
number>string "+line:" prepend 2array
|
||||
make-jedit-request send-jedit-request ;
|
||||
|
||||
: jedit-file ( file -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.notepadpp
|
|||
|
||||
: notepadpp-path
|
||||
\ notepadpp-path get-global [
|
||||
program-files "notepad++\\notepad++.exe" path+
|
||||
program-files "notepad++\\notepad++.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: notepadpp ( file line -- )
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: editors.scite
|
|||
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "wscite\\SciTE.exe" path+
|
||||
program-files "wscite\\SciTE.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.ted-notepad
|
|||
|
||||
: ted-notepad-path
|
||||
\ ted-notepad-path get-global [
|
||||
program-files "\\TED Notepad\\TedNPad.exe" path+
|
||||
program-files "\\TED Notepad\\TedNPad.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: ted-notepad ( file line -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: editors.ultraedit
|
|||
: ultraedit-path ( -- path )
|
||||
\ ultraedit-path get-global [
|
||||
program-files
|
||||
"\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
|
||||
"\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: ultraedit ( file line -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: editors.wordpad
|
|||
|
||||
: wordpad-path ( -- path )
|
||||
\ wordpad-path get [
|
||||
program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
|
||||
program-files "\\Windows NT\\Accessories\\wordpad.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: wordpad ( file line -- )
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ C: <faq> faq
|
|||
"br" contained, nl, ;
|
||||
|
||||
: toc-link, ( question-list number -- )
|
||||
number>string "#" swap append "href" swap 2array 1array
|
||||
number>string "#" prepend "href" swap 2array 1array
|
||||
"a" swap [ question-list-title , ] tag*, br, ;
|
||||
|
||||
: toc, ( faq -- )
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
: about ( vocab -- )
|
||||
dup require
|
||||
dup vocab [ ] [
|
||||
"No such vocabulary: " swap append throw
|
||||
"No such vocabulary: " prepend throw
|
||||
] ?if
|
||||
dup vocab-help [
|
||||
help
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ IN: html.elements
|
|||
! <a =href a> "Click me" write </a>
|
||||
!
|
||||
! (url -- )
|
||||
! <a "http://" swap append =href a> "click" write </a>
|
||||
! <a "http://" prepend =href a> "click" write </a>
|
||||
!
|
||||
! (url -- )
|
||||
! <a [ "http://" % % ] "" make =href a> "click" write </a>
|
||||
|
|
@ -72,7 +72,7 @@ SYMBOL: html
|
|||
dup <foo> swap [ <foo> write-html ] curry
|
||||
empty-effect html-word ;
|
||||
|
||||
: <foo "<" swap append ;
|
||||
: <foo "<" prepend ;
|
||||
|
||||
: def-for-html-word-<foo ( name -- )
|
||||
#! Return the name and code for the <foo patterned
|
||||
|
|
@ -134,7 +134,7 @@ SYMBOL: html
|
|||
: attribute-effect T{ effect f { "string" } 0 } ;
|
||||
|
||||
: define-attribute-word ( name -- )
|
||||
dup "=" swap append swap
|
||||
dup "=" prepend swap
|
||||
[ write-attr ] curry attribute-effect html-word ;
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ DEFER: http-request
|
|||
|
||||
: parse-url ( url -- resource host port )
|
||||
"http://" ?head [ "Only http:// supported" throw ] unless
|
||||
"/" split1 [ "/" swap append ] [ "/" ] if*
|
||||
"/" split1 [ "/" prepend ] [ "/" ] if*
|
||||
swap parse-host ;
|
||||
|
||||
: store-path ( request path -- request )
|
||||
|
|
|
|||
|
|
@ -27,8 +27,8 @@ blah
|
|||
] unit-test
|
||||
|
||||
<action>
|
||||
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
|
||||
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
|
||||
[ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
|
||||
{ { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
|
||||
"action-2" set
|
||||
|
||||
STRING: action-request-test-2
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces
|
|||
combinators.cleave fry continuations locals ;
|
||||
IN: http.server.actions
|
||||
|
||||
SYMBOL: +path+
|
||||
SYMBOL: +append-path
|
||||
|
||||
SYMBOL: params
|
||||
|
||||
|
|
@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ;
|
|||
M: action call-responder ( path action -- response )
|
||||
'[
|
||||
, ,
|
||||
[ +path+ associate request-params union params set ]
|
||||
[ +append-path associate request-params union params set ]
|
||||
[ action set ] bi*
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ TUPLE: component id required default ;
|
|||
|
||||
: component ( name -- component )
|
||||
dup components get at
|
||||
[ ] [ "No such component: " swap append throw ] ?if ;
|
||||
[ ] [ "No such component: " prepend throw ] ?if ;
|
||||
|
||||
GENERIC: validate* ( value component -- result )
|
||||
GENERIC: render-view* ( value component -- )
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ TUPLE: file-responder root hook special ;
|
|||
[ 2drop <304> ] [ file-responder get hook>> call ] if ;
|
||||
|
||||
: serving-path ( filename -- filename )
|
||||
"" or file-responder get root>> swap path+ ;
|
||||
"" or file-responder get root>> prepend-path ;
|
||||
|
||||
: serve-file ( filename -- response )
|
||||
dup mime-type
|
||||
|
|
@ -68,7 +68,7 @@ TUPLE: file-responder root hook special ;
|
|||
swap '[ , directory. ] >>body ;
|
||||
|
||||
: find-index ( filename -- path )
|
||||
{ "index.html" "index.fhtml" } [ path+ ] with map
|
||||
{ "index.html" "index.fhtml" } [ append-path ] with map
|
||||
[ exists? ] find nip ;
|
||||
|
||||
: serve-directory ( filename -- response )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: http.server.templating.fhtml.tests
|
|||
|
||||
: test-template ( path -- ? )
|
||||
"resource:extra/http/server/templating/fhtml/test/"
|
||||
swap append
|
||||
prepend
|
||||
[
|
||||
".fhtml" append [ run-template ] with-string-writer
|
||||
] keep
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ C: <validation-error> validation-error
|
|||
|
||||
: v-regexp ( str what regexp -- str )
|
||||
>r over r> matches?
|
||||
[ drop ] [ "invalid " swap append throw ] if ;
|
||||
[ drop ] [ "invalid " prepend throw ] if ;
|
||||
|
||||
: v-email ( str -- str )
|
||||
#! From http://www.regular-expressions.info/email.html
|
||||
|
|
|
|||
|
|
@ -18,13 +18,13 @@ TUPLE: utf16 ;
|
|||
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
|
||||
|
||||
: double-be ( stream byte -- stream char )
|
||||
over stream-read1 swap append-nums ;
|
||||
over stream-read1 prepend-nums ;
|
||||
|
||||
: quad-be ( stream byte -- stream char )
|
||||
double-be over stream-read1 [
|
||||
dup -2 shift BIN: 110111 number= [
|
||||
>r 2 shift r> BIN: 11 bitand bitor
|
||||
over stream-read1 swap append-nums HEX: 10000 +
|
||||
over stream-read1 prepend-nums HEX: 10000 +
|
||||
] [ 2drop dup stream-read1 drop replacement-char ] if
|
||||
] when* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ PRIVATE>
|
|||
: make-unique-file ( prefix suffix -- path stream )
|
||||
temporary-path -rot
|
||||
[
|
||||
unique-length random-name swap 3append path+
|
||||
unique-length random-name swap 3append append-path
|
||||
dup (make-unique-file)
|
||||
] 3curry unique-retries retry ;
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ PRIVATE>
|
|||
|
||||
: make-unique-directory ( -- path )
|
||||
[
|
||||
temporary-path unique-length random-name path+
|
||||
temporary-path unique-length random-name append-path
|
||||
dup make-directory
|
||||
] unique-retries retry ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: io.paths
|
|||
TUPLE: directory-iterator path bfs queue ;
|
||||
|
||||
: qualified-directory ( path -- seq )
|
||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
||||
dup directory [ first2 >r append-path r> 2array ] with map ;
|
||||
|
||||
: push-directory ( path iter -- )
|
||||
>r qualified-directory r> [
|
||||
|
|
|
|||
|
|
@ -32,9 +32,9 @@ M: windows-nt-io root-directory? ( path -- ? )
|
|||
} && [ 2 head ] [ "Not an absolute path" throw ] if ;
|
||||
|
||||
: prepend-prefix ( string -- string' )
|
||||
unicode-prefix swap append ;
|
||||
unicode-prefix prepend ;
|
||||
|
||||
: windows-path+ ( cwd path -- newpath )
|
||||
: windows-append-path ( cwd path -- newpath )
|
||||
{
|
||||
! empty
|
||||
{ [ dup empty? ] [ drop ] }
|
||||
|
|
@ -43,7 +43,7 @@ M: windows-nt-io root-directory? ( path -- ? )
|
|||
! \\\\?\\c:\\foo
|
||||
{ [ dup unicode-prefix head? ] [ nip ] }
|
||||
! ..\\foo
|
||||
{ [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] }
|
||||
{ [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-append-path ] }
|
||||
! .\\foo
|
||||
{ [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] }
|
||||
! \\foo
|
||||
|
|
@ -62,7 +62,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
|
|||
dup string? [ "Pathname must be a string" throw ] unless
|
||||
dup empty? [ "Empty pathname" throw ] when
|
||||
{ { CHAR: / CHAR: \\ } } substitute
|
||||
cwd swap windows-path+
|
||||
cwd swap windows-append-path
|
||||
[ "/\\." member? ] right-trim
|
||||
dup peek CHAR: : = [ "\\" append ] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -22,15 +22,15 @@ IN: io.windows.nt.tests
|
|||
|
||||
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
|
||||
"C:\\builds\\factor\\12345\\"
|
||||
"..\\log.txt" windows-path+
|
||||
"..\\log.txt" windows-append-path
|
||||
] unit-test
|
||||
|
||||
[ "\\\\?\\C:\\builds\\" ] [
|
||||
"C:\\builds\\factor\\12345\\"
|
||||
"..\\.." windows-path+
|
||||
"..\\.." windows-append-path
|
||||
] unit-test
|
||||
|
||||
[ "\\\\?\\C:\\builds\\" ] [
|
||||
"C:\\builds\\factor\\12345\\"
|
||||
"..\\.." windows-path+
|
||||
"..\\.." windows-append-path
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ SYMBOL: terms
|
|||
{
|
||||
{ [ dup 1 = ] [ drop " + " ] }
|
||||
{ [ dup -1 = ] [ drop " - " ] }
|
||||
{ [ t ] [ number>string " + " swap append ] }
|
||||
{ [ t ] [ number>string " + " prepend ] }
|
||||
} cond ;
|
||||
|
||||
: (alt.) ( basis n -- str )
|
||||
|
|
@ -155,7 +155,7 @@ DEFER: (d)
|
|||
|
||||
: (tensor) ( seq1 seq2 -- seq )
|
||||
[
|
||||
[ swap append natural-sort ] curry map
|
||||
[ prepend natural-sort ] curry map
|
||||
] with map concat ;
|
||||
|
||||
: tensor ( graded-basis1 graded-basis2 -- bigraded-basis )
|
||||
|
|
@ -202,7 +202,7 @@ DEFER: (d)
|
|||
: bigraded-betti ( u-generators z-generators -- seq )
|
||||
[ basis graded ] 2apply tensor bigraded-ker/im-d
|
||||
[ [ [ first ] map ] map ] keep
|
||||
[ [ second ] map 2 head* { 0 0 } swap append ] map
|
||||
[ [ second ] map 2 head* { 0 0 } prepend ] map
|
||||
1 tail dup first length 0 <array> add
|
||||
[ v- ] 2map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@ M: block lambda-rewrite*
|
|||
#! Turn free variables into bound variables, curry them
|
||||
#! onto the body
|
||||
dup free-vars [ <quote> ] map dup % [
|
||||
over block-vars swap append
|
||||
over block-vars prepend
|
||||
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
|
||||
swap point-free ,
|
||||
] keep length \ curry <repetition> % ;
|
||||
|
|
|
|||
|
|
@ -11,10 +11,10 @@ IN: logging.server
|
|||
\ log-root get "logs" resource-path or ;
|
||||
|
||||
: log-path ( service -- path )
|
||||
log-root swap path+ ;
|
||||
log-root prepend-path ;
|
||||
|
||||
: log# ( path n -- path' )
|
||||
number>string ".log" append path+ ;
|
||||
number>string ".log" append append-path ;
|
||||
|
||||
SYMBOL: log-files
|
||||
|
||||
|
|
|
|||
|
|
@ -12,4 +12,4 @@ IN: math.haar
|
|||
2 group dup averages [ differences ] keep ;
|
||||
|
||||
: haar ( seq -- seq )
|
||||
dup length 1 <= [ haar-step haar swap append ] unless ;
|
||||
dup length 1 <= [ haar-step haar prepend ] unless ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ IN: new-slots
|
|||
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
|
||||
|
||||
: setter-word ( name -- word )
|
||||
">>" swap append setter-effect create-accessor ;
|
||||
">>" prepend setter-effect create-accessor ;
|
||||
|
||||
: define-setter ( name -- )
|
||||
dup setter-word dup deferred? [
|
||||
|
|
@ -37,7 +37,7 @@ IN: new-slots
|
|||
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
|
||||
|
||||
: changer-word ( name -- word )
|
||||
"change-" swap append changer-effect create-accessor ;
|
||||
"change-" prepend changer-effect create-accessor ;
|
||||
|
||||
: define-changer ( name -- )
|
||||
dup changer-word dup deferred? [
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ MATCH-VARS: ?a ?b ?c ;
|
|||
M: #shuffle node>quot
|
||||
dup node-in-d over node-out-d pretty-shuffle
|
||||
[ , ] [ >r drop t r> ] if*
|
||||
dup effect-str "#shuffle: " swap append comment, ;
|
||||
dup effect-str "#shuffle: " prepend comment, ;
|
||||
|
||||
: pushed-literals node-out-d [ value-literal literalize ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ PRIVATE>
|
|||
|
||||
: fib-upto* ( n -- seq )
|
||||
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
|
||||
1 head-slice* { 0 1 } swap append ;
|
||||
1 head-slice* { 0 1 } prepend ;
|
||||
|
||||
: euler002a ( -- answer )
|
||||
1000000 fib-upto* [ even? ] subset sum ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: project-euler.035
|
|||
] if ;
|
||||
|
||||
: rotate ( seq n -- seq )
|
||||
cut* swap append ;
|
||||
cut* prepend ;
|
||||
|
||||
: (circular?) ( seq n -- ? )
|
||||
dup 0 > [
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ IN: project-euler
|
|||
number>string 3 CHAR: 0 pad-left ;
|
||||
|
||||
: solution-path ( n -- str/f )
|
||||
number>euler "project-euler." swap append
|
||||
number>euler "project-euler." prepend
|
||||
vocab where dup [ first ?resource-path ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -40,7 +40,7 @@ PRIVATE>
|
|||
|
||||
: run-project-euler ( -- )
|
||||
problem-prompt dup problem-solved? [
|
||||
dup number>euler "project-euler." swap append run
|
||||
dup number>euler "project-euler." prepend run
|
||||
"Answer: " swap dup number? [ number>string ] when append print
|
||||
"Source: " swap solution-path append print
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
|
|||
: validate-address ( string -- string' )
|
||||
#! Make sure we send funky stuff to the server by accident.
|
||||
dup "\r\n>" seq-intersect empty?
|
||||
[ "Bad e-mail address: " swap append throw ] unless ;
|
||||
[ "Bad e-mail address: " prepend throw ] unless ;
|
||||
|
||||
: mail-from ( fromaddr -- )
|
||||
"MAIL FROM:<" write validate-address write ">" write crlf ;
|
||||
|
|
@ -89,7 +89,7 @@ LOG: smtp-response DEBUG
|
|||
|
||||
: validate-header ( string -- string' )
|
||||
dup "\r\n" seq-intersect empty?
|
||||
[ "Invalid header string: " swap append throw ] unless ;
|
||||
[ "Invalid header string: " prepend throw ] unless ;
|
||||
|
||||
: write-header ( key value -- )
|
||||
swap
|
||||
|
|
@ -143,7 +143,7 @@ M: email clone
|
|||
dup to>> ", " join "To" set-header
|
||||
[ [ extract-email ] map ] change-to
|
||||
dup subject>> "Subject" set-header
|
||||
now timestamp>rfc822-string "Date" set-header
|
||||
now timestamp>rfc822 "Date" set-header
|
||||
message-id "Message-Id" set-header ;
|
||||
|
||||
: <email> ( -- email )
|
||||
|
|
@ -164,7 +164,7 @@ M: email clone
|
|||
! : (cram-md5-auth) ( -- response )
|
||||
! swap challenge get
|
||||
! string>md5-hmac hex-string
|
||||
! " " swap append append
|
||||
! " " prepend append
|
||||
! >base64 ;
|
||||
!
|
||||
! : cram-md5-auth ( key login -- )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: strings.lib
|
|||
|
||||
: >Upper ( str -- str )
|
||||
dup empty? [
|
||||
unclip ch>upper 1string swap append
|
||||
unclip ch>upper 1string prepend
|
||||
] unless ;
|
||||
|
||||
: >Upper-dashes ( str -- str )
|
||||
|
|
|
|||
|
|
@ -89,12 +89,12 @@ TUPLE: unimplemented-typeflag header ;
|
|||
tar-header-typeflag
|
||||
1string \ unimplemented-typeflag construct-boa ;
|
||||
|
||||
: tar-path+ ( path -- newpath )
|
||||
base-dir get swap path+ ;
|
||||
: tar-append-path ( path -- newpath )
|
||||
base-dir get prepend-path ;
|
||||
|
||||
! Normal file
|
||||
: typeflag-0
|
||||
tar-header-name tar-path+ binary <file-writer>
|
||||
tar-header-name tar-append-path binary <file-writer>
|
||||
[ read-data-blocks ] keep dispose ;
|
||||
|
||||
! Hard link
|
||||
|
|
@ -115,7 +115,7 @@ TUPLE: unimplemented-typeflag header ;
|
|||
|
||||
! Directory
|
||||
: typeflag-5 ( header -- )
|
||||
tar-header-name tar-path+ make-directories ;
|
||||
tar-header-name tar-append-path make-directories ;
|
||||
|
||||
! FIFO
|
||||
: typeflag-6 ( header -- )
|
||||
|
|
@ -166,7 +166,7 @@ TUPLE: unimplemented-typeflag header ;
|
|||
<string-writer> [ read-data-blocks ] keep
|
||||
>string [ zero? ] right-trim filename set
|
||||
global [ "long filename: " write filename get . flush ] bind
|
||||
filename get tar-path+ make-directories ;
|
||||
filename get tar-append-path make-directories ;
|
||||
|
||||
! Multi volume continuation entry
|
||||
: typeflag-M ( header -- )
|
||||
|
|
@ -226,7 +226,7 @@ TUPLE: unimplemented-typeflag header ;
|
|||
! drop
|
||||
! ] [
|
||||
! dup tar-header-name
|
||||
! dup parent-dir base-dir swap path+
|
||||
! dup parent-dir base-dir prepend-path
|
||||
! global [ dup [ . flush ] when* ] bind
|
||||
! make-directories <file-writer>
|
||||
! out-stream set
|
||||
|
|
|
|||
|
|
@ -79,9 +79,9 @@ IN: tools.deploy.backend
|
|||
|
||||
"-run=tools.deploy.shaker" ,
|
||||
|
||||
"-deploy-vocab=" swap append ,
|
||||
"-deploy-vocab=" prepend ,
|
||||
|
||||
"-output-image=" swap append ,
|
||||
"-output-image=" prepend ,
|
||||
|
||||
strip-word-names? [ "-no-stack-traces" , ] when
|
||||
] { } make
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ SYMBOL: deploy-image
|
|||
} union ;
|
||||
|
||||
: deploy-config-path ( vocab -- string )
|
||||
vocab-dir "deploy.factor" path+ ;
|
||||
vocab-dir "deploy.factor" append-path ;
|
||||
|
||||
: deploy-config ( vocab -- assoc )
|
||||
dup default-config swap
|
||||
|
|
|
|||
|
|
@ -10,15 +10,15 @@ IN: tools.deploy.macosx
|
|||
vm parent-directory parent-directory ;
|
||||
|
||||
: copy-bundle-dir ( bundle-name dir -- )
|
||||
bundle-dir over path+ -rot
|
||||
"Contents" swap path+ path+ copy-tree ;
|
||||
bundle-dir over append-path -rot
|
||||
"Contents" prepend-path append-path copy-tree ;
|
||||
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
"Contents/MacOS/" path+ swap path+ vm over copy-file ;
|
||||
"Contents/MacOS/" append-path prepend-path vm over copy-file ;
|
||||
|
||||
: copy-fonts ( name -- )
|
||||
"fonts/" resource-path
|
||||
swap "Contents/Resources/" path+ copy-tree-into ;
|
||||
swap "Contents/Resources/" append-path copy-tree-into ;
|
||||
|
||||
: app-plist ( executable bundle-name -- string )
|
||||
[
|
||||
|
|
@ -30,12 +30,12 @@ IN: tools.deploy.macosx
|
|||
file-name "CFBundleName" set
|
||||
|
||||
dup "CFBundleExecutable" set
|
||||
"org.factor." swap append "CFBundleIdentifier" set
|
||||
"org.factor." prepend "CFBundleIdentifier" set
|
||||
] H{ } make-assoc plist>string ;
|
||||
|
||||
: create-app-plist ( vocab bundle-name -- )
|
||||
[ app-plist ] keep
|
||||
"Contents/Info.plist" path+
|
||||
"Contents/Info.plist" append-path
|
||||
utf8 set-file-contents ;
|
||||
|
||||
: create-app-dir ( vocab bundle-name -- vm )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ prettyprint windows.shell32 windows.user32 ;
|
|||
IN: tools.deploy.windows
|
||||
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
swap path+ ".exe" append
|
||||
prepend-path ".exe" append
|
||||
vm over copy-file ;
|
||||
|
||||
: copy-fonts ( bundle-name -- )
|
||||
|
|
@ -23,7 +23,7 @@ IN: tools.deploy.windows
|
|||
copy-vm ;
|
||||
|
||||
: image-name ( vocab bundle-name -- str )
|
||||
swap path+ ".image" append ;
|
||||
prepend-path ".image" append ;
|
||||
|
||||
TUPLE: windows-deploy-implementation ;
|
||||
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ IN: tools.vocabs.browser
|
|||
] with-row ;
|
||||
|
||||
: root-heading. ( root -- )
|
||||
[ "Children from " swap append ] [ "Children" ] if*
|
||||
[ "Children from " prepend ] [ "Children" ] if*
|
||||
$heading ;
|
||||
|
||||
: vocabs. ( assoc -- )
|
||||
|
|
@ -195,7 +195,7 @@ M: vocab-tag summary article-title ;
|
|||
M: vocab-author >link ;
|
||||
|
||||
M: vocab-author article-title
|
||||
vocab-author-name "Vocabularies by " swap append ;
|
||||
vocab-author-name "Vocabularies by " prepend ;
|
||||
|
||||
M: vocab-author article-name vocab-author-name ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,15 +7,15 @@ io debugger continuations compiler.errors init io.crc32 ;
|
|||
IN: tools.vocabs
|
||||
|
||||
: vocab-tests-file ( vocab -- path )
|
||||
dup "-tests.factor" vocab-dir+ vocab-path+ dup
|
||||
dup "-tests.factor" vocab-dir+ vocab-append-path dup
|
||||
[ dup resource-exists? [ drop f ] unless ] [ drop f ] if ;
|
||||
|
||||
: vocab-tests-dir ( vocab -- paths )
|
||||
dup vocab-dir "tests" path+ vocab-path+ dup [
|
||||
dup vocab-dir "tests" append-path vocab-append-path dup [
|
||||
dup resource-exists? [
|
||||
dup ?resource-path directory keys
|
||||
[ ".factor" tail? ] subset
|
||||
[ path+ ] with map
|
||||
[ append-path ] with map
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
|
|
@ -103,10 +103,10 @@ MEMO: (vocab-file-contents) ( path -- lines )
|
|||
[ utf8 file-lines ] [ drop f ] if ;
|
||||
|
||||
: vocab-file-contents ( vocab name -- seq )
|
||||
vocab-path+ dup [ (vocab-file-contents) ] when ;
|
||||
vocab-append-path dup [ (vocab-file-contents) ] when ;
|
||||
|
||||
: set-vocab-file-contents ( seq vocab name -- )
|
||||
dupd vocab-path+ [
|
||||
dupd vocab-append-path [
|
||||
?resource-path utf8 set-file-lines
|
||||
] [
|
||||
"The " swap vocab-name
|
||||
|
|
@ -115,7 +115,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
|
|||
] ?if ;
|
||||
|
||||
: vocab-summary-path ( vocab -- string )
|
||||
vocab-dir "summary.txt" path+ ;
|
||||
vocab-dir "summary.txt" append-path ;
|
||||
|
||||
: vocab-summary ( vocab -- summary )
|
||||
dup dup vocab-summary-path vocab-file-contents
|
||||
|
|
@ -141,7 +141,7 @@ M: vocab-link summary vocab-summary ;
|
|||
set-vocab-file-contents ;
|
||||
|
||||
: vocab-tags-path ( vocab -- string )
|
||||
vocab-dir "tags.txt" path+ ;
|
||||
vocab-dir "tags.txt" append-path ;
|
||||
|
||||
: vocab-tags ( vocab -- tags )
|
||||
dup vocab-tags-path vocab-file-contents ;
|
||||
|
|
@ -153,7 +153,7 @@ M: vocab-link summary vocab-summary ;
|
|||
[ vocab-tags append prune ] keep set-vocab-tags ;
|
||||
|
||||
: vocab-authors-path ( vocab -- string )
|
||||
vocab-dir "authors.txt" path+ ;
|
||||
vocab-dir "authors.txt" append-path ;
|
||||
|
||||
: vocab-authors ( vocab -- authors )
|
||||
dup vocab-authors-path vocab-file-contents ;
|
||||
|
|
@ -165,7 +165,7 @@ M: vocab-link summary vocab-summary ;
|
|||
directory [ second ] subset keys natural-sort ;
|
||||
|
||||
: (all-child-vocabs) ( root name -- vocabs )
|
||||
[ vocab-dir path+ ?resource-path subdirs ] keep
|
||||
[ vocab-dir append-path ?resource-path subdirs ] keep
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ TUPLE: tuple-array example ;
|
|||
[ set-tuple-array-example ] keep ;
|
||||
|
||||
: reconstruct ( seq example -- tuple )
|
||||
swap append >tuple ;
|
||||
prepend >tuple ;
|
||||
|
||||
M: tuple-array nth
|
||||
[ delegate nth ] keep
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ TUPLE: list index presenter color hook ;
|
|||
swap set-list-index ;
|
||||
|
||||
: list-presentation-hook ( list -- quot )
|
||||
list-hook [ [ [ list? ] is? ] find-parent ] swap append ;
|
||||
list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
|
||||
|
||||
: <list-presentation> ( hook elt presenter -- gadget )
|
||||
keep <presentation>
|
||||
|
|
|
|||
|
|
@ -29,4 +29,4 @@ SYMBOL: width
|
|||
broken-lines "\n" join ;
|
||||
|
||||
: indented-break ( string width indent -- newstring )
|
||||
[ length - broken-lines ] keep [ swap append ] curry map "\n" join ;
|
||||
[ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
|
||||
|
|
|
|||
|
|
@ -37,13 +37,13 @@ TAGS>
|
|||
|
||||
MEMO: (load-mode) ( name -- rule-sets )
|
||||
modes at mode-file
|
||||
"extra/xmode/modes/" swap append
|
||||
"extra/xmode/modes/" prepend
|
||||
resource-path utf8 <file-reader> parse-mode ;
|
||||
|
||||
SYMBOL: rule-sets
|
||||
|
||||
: no-such-rule-set ( name -- * )
|
||||
"No such rule set: " swap append throw ;
|
||||
"No such rule set: " prepend throw ;
|
||||
|
||||
: get-rule-set ( name -- rule-sets rules )
|
||||
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
|
||||
|
|
|
|||
Loading…
Reference in New Issue