path+, prepend
parent
3e7940216e
commit
d0b348591a
|
@ -25,7 +25,7 @@ SYMBOL: bootstrap-time
|
||||||
"exclude" "include"
|
"exclude" "include"
|
||||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||||
seq-diff
|
seq-diff
|
||||||
[ "bootstrap." swap append require ] each ;
|
[ "bootstrap." prepend require ] each ;
|
||||||
|
|
||||||
: compile-remaining ( -- )
|
: compile-remaining ( -- )
|
||||||
"Compiling remaining words..." print flush
|
"Compiling remaining words..." print flush
|
||||||
|
|
|
@ -13,7 +13,7 @@ PREDICATE: class union-class
|
||||||
drop [ drop f ]
|
drop [ drop f ]
|
||||||
] [
|
] [
|
||||||
unclip first "predicate" word-prop swap
|
unclip first "predicate" word-prop swap
|
||||||
[ >r "predicate" word-prop [ dup ] swap append r> ]
|
[ >r "predicate" word-prop [ dup ] prepend r> ]
|
||||||
assoc-map alist>quot
|
assoc-map alist>quot
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -80,7 +80,7 @@ M: hashtable hashcode*
|
||||||
|
|
||||||
: hash-case-quot ( default assoc -- quot )
|
: hash-case-quot ( default assoc -- quot )
|
||||||
hash-case-table hash-dispatch-quot
|
hash-case-table hash-dispatch-quot
|
||||||
[ dup hashcode >fixnum ] swap append ;
|
[ dup hashcode >fixnum ] prepend ;
|
||||||
|
|
||||||
: contiguous-range? ( keys -- from to ? )
|
: contiguous-range? ( keys -- from to ? )
|
||||||
dup [ fixnum? ] all? [
|
dup [ fixnum? ] all? [
|
||||||
|
|
|
@ -7,12 +7,12 @@ splitting io.files ;
|
||||||
|
|
||||||
: run-bootstrap-init ( -- )
|
: run-bootstrap-init ( -- )
|
||||||
"user-init" get [
|
"user-init" get [
|
||||||
home ".factor-boot-rc" path+ ?run-file
|
home ".factor-boot-rc" append-path ?run-file
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: run-user-init ( -- )
|
: run-user-init ( -- )
|
||||||
"user-init" get [
|
"user-init" get [
|
||||||
home ".factor-rc" path+ ?run-file
|
home ".factor-rc" append-path ?run-file
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: cli-var-param ( name value -- ) swap set-global ;
|
: cli-var-param ( name value -- ) swap set-global ;
|
||||||
|
|
|
@ -385,7 +385,7 @@ cell 8 = [
|
||||||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||||
|
|
||||||
: xword-def word-def [ { fixnum } declare ] swap append ;
|
: xword-def word-def [ { fixnum } declare ] prepend ;
|
||||||
|
|
||||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||||
|
|
|
@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ;
|
||||||
2dup and [
|
2dup and [
|
||||||
2dup math-upgrade >r
|
2dup math-upgrade >r
|
||||||
math-class-max over order min-class applicable-method
|
math-class-max over order min-class applicable-method
|
||||||
r> swap append
|
r> prepend
|
||||||
] [
|
] [
|
||||||
2drop object-method
|
2drop object-method
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -161,7 +161,7 @@ C: <hook-combination> hook-combination
|
||||||
0 (dispatch#) [
|
0 (dispatch#) [
|
||||||
swap slip
|
swap slip
|
||||||
hook-combination-var [ get ] curry
|
hook-combination-var [ get ] curry
|
||||||
swap append
|
prepend
|
||||||
] with-variable ; inline
|
] with-variable ; inline
|
||||||
|
|
||||||
M: hook-combination make-default-method
|
M: hook-combination make-default-method
|
||||||
|
@ -170,7 +170,7 @@ M: hook-combination make-default-method
|
||||||
M: hook-combination perform-combination
|
M: hook-combination perform-combination
|
||||||
[
|
[
|
||||||
standard-methods
|
standard-methods
|
||||||
[ [ drop ] swap append ] assoc-map
|
[ [ drop ] prepend ] assoc-map
|
||||||
single-combination
|
single-combination
|
||||||
] with-hook ;
|
] with-hook ;
|
||||||
|
|
||||||
|
|
|
@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation"
|
||||||
{ $subsection parent-directory }
|
{ $subsection parent-directory }
|
||||||
{ $subsection file-name }
|
{ $subsection file-name }
|
||||||
{ $subsection last-path-separator }
|
{ $subsection last-path-separator }
|
||||||
{ $subsection path+ }
|
{ $subsection append-path }
|
||||||
"Pathnames relative to Factor's install directory:"
|
"Pathnames relative to Factor's install directory:"
|
||||||
{ $subsection resource-path }
|
{ $subsection resource-path }
|
||||||
{ $subsection ?resource-path }
|
{ $subsection ?resource-path }
|
||||||
|
@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified )
|
||||||
|
|
||||||
{ stat exists? directory? } related-words
|
{ stat exists? directory? } related-words
|
||||||
|
|
||||||
HELP: path+
|
HELP: append-path
|
||||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||||
{ $description "Concatenates two pathnames." } ;
|
{ $description "Concatenates two pathnames." } ;
|
||||||
|
|
||||||
|
|
|
@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- )
|
||||||
: left-trim-separators ( str -- newstr )
|
: left-trim-separators ( str -- newstr )
|
||||||
[ path-separator? ] left-trim ;
|
[ path-separator? ] left-trim ;
|
||||||
|
|
||||||
: path+ ( str1 str2 -- str )
|
: append-path ( str1 str2 -- str )
|
||||||
>r right-trim-separators "/" r>
|
>r right-trim-separators "/" r>
|
||||||
left-trim-separators 3append ;
|
left-trim-separators 3append ;
|
||||||
|
|
||||||
|
: prepend-path ( str1 str2 -- str )
|
||||||
|
swap append-path ; inline
|
||||||
|
|
||||||
: last-path-separator ( path -- n ? )
|
: last-path-separator ( path -- n ? )
|
||||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||||
|
|
||||||
|
@ -119,7 +122,7 @@ HOOK: make-directory io-backend ( path -- )
|
||||||
: fixup-directory ( path seq -- newseq )
|
: fixup-directory ( path seq -- newseq )
|
||||||
[
|
[
|
||||||
dup string?
|
dup string?
|
||||||
[ tuck path+ directory? 2array ] [ nip ] if
|
[ tuck append-path directory? 2array ] [ nip ] if
|
||||||
] with map
|
] with map
|
||||||
[ first special-directory? not ] subset ;
|
[ first special-directory? not ] subset ;
|
||||||
|
|
||||||
|
@ -127,7 +130,7 @@ HOOK: make-directory io-backend ( path -- )
|
||||||
normalize-directory dup (directory) fixup-directory ;
|
normalize-directory dup (directory) fixup-directory ;
|
||||||
|
|
||||||
: directory* ( path -- seq )
|
: directory* ( path -- seq )
|
||||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
dup directory [ first2 >r append-path r> 2array ] with map ;
|
||||||
|
|
||||||
! Touching files
|
! Touching files
|
||||||
HOOK: touch-file io-backend ( path -- )
|
HOOK: touch-file io-backend ( path -- )
|
||||||
|
@ -146,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- )
|
||||||
: delete-tree ( path -- )
|
: delete-tree ( path -- )
|
||||||
dup directory? (delete-tree) ;
|
dup directory? (delete-tree) ;
|
||||||
|
|
||||||
: to-directory over file-name path+ ;
|
: to-directory over file-name append-path ;
|
||||||
|
|
||||||
! Moving and renaming files
|
! Moving and renaming files
|
||||||
HOOK: move-file io-backend ( from to -- )
|
HOOK: move-file io-backend ( from to -- )
|
||||||
|
@ -179,7 +182,7 @@ DEFER: copy-tree-into
|
||||||
: copy-tree ( from to -- )
|
: copy-tree ( from to -- )
|
||||||
over directory? [
|
over directory? [
|
||||||
>r dup directory swap r> [
|
>r dup directory swap r> [
|
||||||
>r swap first path+ r> copy-tree-into
|
>r swap first append-path r> copy-tree-into
|
||||||
] 2curry each
|
] 2curry each
|
||||||
] [
|
] [
|
||||||
copy-file
|
copy-file
|
||||||
|
@ -194,7 +197,7 @@ DEFER: copy-tree-into
|
||||||
! Special paths
|
! Special paths
|
||||||
: resource-path ( path -- newpath )
|
: resource-path ( path -- newpath )
|
||||||
\ resource-path get [ image parent-directory ] unless*
|
\ resource-path get [ image parent-directory ] unless*
|
||||||
swap path+ ;
|
prepend-path ;
|
||||||
|
|
||||||
: ?resource-path ( path -- newpath )
|
: ?resource-path ( path -- newpath )
|
||||||
"resource:" ?head [ resource-path ] when ;
|
"resource:" ?head [ resource-path ] when ;
|
||||||
|
@ -236,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ;
|
||||||
[ dup make-directory ]
|
[ dup make-directory ]
|
||||||
when ;
|
when ;
|
||||||
|
|
||||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
: temp-file ( name -- path ) temp-directory prepend-path ;
|
||||||
|
|
||||||
! Home directory
|
! Home directory
|
||||||
: home ( -- dir )
|
: home ( -- dir )
|
||||||
|
|
|
@ -35,7 +35,7 @@ IN: optimizer.specializers
|
||||||
swap "method-class" word-prop add* ;
|
swap "method-class" word-prop add* ;
|
||||||
|
|
||||||
: specialize-method ( quot method -- quot' )
|
: specialize-method ( quot method -- quot' )
|
||||||
method-declaration [ declare ] curry swap append ;
|
method-declaration [ declare ] curry prepend ;
|
||||||
|
|
||||||
: specialize-quot ( quot specializer -- quot' )
|
: specialize-quot ( quot specializer -- quot' )
|
||||||
dup { number } = [
|
dup { number } = [
|
||||||
|
|
|
@ -299,6 +299,8 @@ M: immutable-sequence clone-like like ;
|
||||||
|
|
||||||
: append ( seq1 seq2 -- newseq ) over (append) ;
|
: append ( seq1 seq2 -- newseq ) over (append) ;
|
||||||
|
|
||||||
|
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
|
||||||
|
|
||||||
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
|
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
|
||||||
|
|
||||||
: change-nth ( i seq quot -- )
|
: change-nth ( i seq quot -- )
|
||||||
|
|
|
@ -163,6 +163,11 @@ IN: bootstrap.syntax
|
||||||
[ construct-boa ] curry define-inline
|
[ construct-boa ] curry define-inline
|
||||||
] define-syntax
|
] define-syntax
|
||||||
|
|
||||||
|
"ERROR:" [
|
||||||
|
CREATE-CLASS dup ";" parse-tokens define-tuple-class
|
||||||
|
dup [ construct-boa throw ] curry define
|
||||||
|
] define-syntax
|
||||||
|
|
||||||
"FORGET:" [
|
"FORGET:" [
|
||||||
scan-word
|
scan-word
|
||||||
dup parsing? [ V{ } clone swap execute first ] when
|
dup parsing? [ V{ } clone swap execute first ] when
|
||||||
|
|
|
@ -136,7 +136,7 @@ IN: vocabs.loader.tests
|
||||||
[
|
[
|
||||||
{ "2" "a" "b" "d" "e" "f" }
|
{ "2" "a" "b" "d" "e" "f" }
|
||||||
[
|
[
|
||||||
"vocabs.loader.test." swap append forget-vocab
|
"vocabs.loader.test." prepend forget-vocab
|
||||||
] each
|
] each
|
||||||
] with-compilation-unit ;
|
] with-compilation-unit ;
|
||||||
|
|
||||||
|
|
|
@ -25,7 +25,7 @@ V{
|
||||||
|
|
||||||
: vocab-dir? ( root name -- ? )
|
: vocab-dir? ( root name -- ? )
|
||||||
over [
|
over [
|
||||||
".factor" vocab-dir+ path+ resource-exists?
|
".factor" vocab-dir+ append-path resource-exists?
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
@ -39,14 +39,14 @@ H{ } clone root-cache set-global
|
||||||
vocab-roots get swap [ vocab-dir? ] curry find nip
|
vocab-roots get swap [ vocab-dir? ] curry find nip
|
||||||
] cache ;
|
] cache ;
|
||||||
|
|
||||||
: vocab-path+ ( vocab path -- newpath )
|
: vocab-append-path ( vocab path -- newpath )
|
||||||
swap find-vocab-root dup [ swap path+ ] [ 2drop f ] if ;
|
swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: vocab-source-path ( vocab -- path/f )
|
: vocab-source-path ( vocab -- path/f )
|
||||||
dup ".factor" vocab-dir+ vocab-path+ ;
|
dup ".factor" vocab-dir+ vocab-append-path ;
|
||||||
|
|
||||||
: vocab-docs-path ( vocab -- path/f )
|
: vocab-docs-path ( vocab -- path/f )
|
||||||
dup "-docs.factor" vocab-dir+ vocab-path+ ;
|
dup "-docs.factor" vocab-dir+ vocab-append-path ;
|
||||||
|
|
||||||
SYMBOL: load-help?
|
SYMBOL: load-help?
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue