core/basis: Rename tuples kernel:curry -> curried, kernel:compose -> composed.

Also rename the stack-checker curried -> curried-effect, composed -> composed-effect.
char-rename
Doug Coleman 2017-06-02 17:02:08 -05:00
parent 1dc65c13e7
commit 32710df620
12 changed files with 81 additions and 85 deletions

View File

@ -48,7 +48,7 @@ gc
array? hashtable? vector? array? hashtable? vector?
tuple? sbuf? tombstone? tuple? sbuf? tombstone?
curry? compose? callable? curried? composed? callable?
quotation? quotation?
curry compose uncurry curry compose uncurry

View File

@ -33,14 +33,14 @@ IDENTITY-MEMO: inputs/outputs ( quot -- in out )
] if* ] if*
] "special" set-word-prop ] "special" set-word-prop
M: curried infer-known* M: curried-effect infer-known*
quot>> infer-known dup [ quot>> infer-known dup [
curry-effect curry-effect
] [ ] [
drop f drop f
] if ; ] if ;
M: composed infer-known* M: composed-effect infer-known*
[ quot1>> ] [ quot2>> ] bi [ quot1>> ] [ quot2>> ] bi
[ infer-known ] bi@ [ infer-known ] bi@
2dup and [ compose-effects ] [ 2drop f ] if ; 2dup and [ compose-effects ] [ 2drop f ] if ;

View File

@ -28,7 +28,7 @@ M: +unknown+ curry-effect* ;
M: effect curry-effect* curry-effect ; M: effect curry-effect* curry-effect ;
M: curry cached-effect M: curried cached-effect
quot>> cached-effect curry-effect* ; quot>> cached-effect curry-effect* ;
: compose-effects* ( effect1 effect2 -- effect' ) : compose-effects* ( effect1 effect2 -- effect' )
@ -37,9 +37,6 @@ M: curry cached-effect
{ [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] } { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
} cond ; } cond ;
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect ) : safe-infer ( quot -- effect )
error get-global error-continuation get-global error get-global error-continuation get-global
[ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
@ -111,9 +108,9 @@ M: quotation cached-effect
GENERIC: already-inlined-quot? ( quot -- ? ) GENERIC: already-inlined-quot? ( quot -- ? )
M: curry already-inlined-quot? quot>> already-inlined-quot? ; M: curried already-inlined-quot? quot>> already-inlined-quot? ;
M: compose already-inlined-quot? M: composed already-inlined-quot?
[ first>> already-inlined-quot? ] [ first>> already-inlined-quot? ]
[ second>> already-inlined-quot? ] bi or ; [ second>> already-inlined-quot? ] bi or ;
@ -121,9 +118,9 @@ M: quotation already-inlined-quot? already-inlined? ;
GENERIC: add-quot-to-history ( quot -- ) GENERIC: add-quot-to-history ( quot -- )
M: curry add-quot-to-history quot>> add-quot-to-history ; M: curried add-quot-to-history quot>> add-quot-to-history ;
M: compose add-quot-to-history M: composed add-quot-to-history
[ first>> add-quot-to-history ] [ first>> add-quot-to-history ]
[ second>> add-quot-to-history ] bi ; [ second>> add-quot-to-history ] bi ;
@ -149,8 +146,8 @@ ERROR: uninferable ;
[ safe-infer dup +unknown+ = [ uninferable ] when ] tri [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
] [ ] [
dup class>> { dup class>> {
{ \ curry [ slots>> third (infer-value) remove-effect-input ] } { \ curried [ slots>> third (infer-value) remove-effect-input ] }
{ \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] } { \ composed [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
[ uninferable ] [ uninferable ]
} case } case
] if ; ] if ;
@ -163,11 +160,11 @@ ERROR: uninferable ;
literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
] [ ] [
dup class>> { dup class>> {
{ \ curry [ { \ curried [
slots>> third (value>quot) slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ] '[ [ obj>> ] [ quot>> @ ] bi ]
] } ] }
{ \ compose [ { \ composed [
slots>> last2 [ (value>quot) ] bi@ slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ] '[ [ first>> @ ] [ second>> @ ] bi ]
] } ] }

View File

@ -211,8 +211,8 @@ M: tuple pprint*
[ number>string "~" " more~" surround text ] when* ; [ number>string "~" " more~" surround text ] when* ;
M: quotation pprint-delims drop \ [ \ ] ; M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ; M: curried pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ; M: composed pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ; M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ; M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ; M: byte-vector pprint-delims drop \ BV{ \ } ;
@ -274,8 +274,8 @@ M: byte-vector pprint* pprint-object ;
M: hashtable pprint* M: hashtable pprint*
[ pprint-object ] with-extra-nesting-level ; [ pprint-object ] with-extra-nesting-level ;
M: curry pprint* pprint-object ; M: curried pprint* pprint-object ;
M: compose pprint* pprint-object ; M: composed pprint* pprint-object ;
M: hash-set pprint* pprint-object ; M: hash-set pprint* pprint-object ;
M: anonymous-union pprint* pprint-object ; M: anonymous-union pprint* pprint-object ;
M: anonymous-intersection pprint* pprint-object ; M: anonymous-intersection pprint* pprint-object ;

View File

@ -139,8 +139,8 @@ M: callable infer-branch
GENERIC: curried/composed? ( known -- ? ) GENERIC: curried/composed? ( known -- ? )
M: object curried/composed? drop f ; M: object curried/composed? drop f ;
M: curried curried/composed? drop t ; M: curried-effect curried/composed? drop t ;
M: composed curried/composed? drop t ; M: composed-effect curried/composed? drop t ;
M: declared-effect curried/composed? known>> curried/composed? ; M: declared-effect curried/composed? known>> curried/composed? ;
: declare-if-effects ( -- ) : declare-if-effects ( -- )

View File

@ -105,14 +105,14 @@ GENERIC: infer-call* ( value known -- )
M: literal-tuple infer-call* M: literal-tuple infer-call*
[ 1array #drop, ] [ infer-literal-quot ] bi* ; [ 1array #drop, ] [ infer-literal-quot ] bi* ;
M: curried infer-call* M: curried-effect infer-call*
swap push-d swap push-d
[ uncurry ] infer-quot-here [ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ] [ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi [ obj>> known pop-d [ set-known ] keep ] bi
push-d (infer-call) ; push-d (infer-call) ;
M: composed infer-call* M: composed-effect infer-call*
swap push-d swap push-d
[ uncompose ] infer-quot-here [ uncompose ] infer-quot-here
[ quot2>> known pop-d [ set-known ] keep ] [ quot2>> known pop-d [ set-known ] keep ]
@ -151,11 +151,11 @@ M: object infer-call* \ call bad-macro-input ;
2 consume-d dup first2 quot call make-known 2 consume-d dup first2 quot call make-known
[ push-d ] [ 1array ] bi word #call, ; inline [ push-d ] [ 1array ] bi word #call, ; inline
: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ; : infer-curry ( -- ) [ <curried-effect> ] \ curry infer-builder ;
\ curry [ infer-curry ] "special" set-word-prop \ curry [ infer-curry ] "special" set-word-prop
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ; : infer-compose ( -- ) [ <composed-effect> ] \ compose infer-builder ;
\ compose [ infer-compose ] "special" set-word-prop \ compose [ infer-compose ] "special" set-word-prop

View File

@ -1,10 +1,10 @@
USING: hashtables help.markup help.syntax math quotations sequences words ; USING: hashtables help.markup help.syntax math quotations sequences words ;
IN: stack-checker.values IN: stack-checker.values
HELP: curried HELP: curried-effect
{ $class-description "Result of curry." } ; { $class-description "Result of curry." } ;
HELP: composed HELP: composed-effect
{ $class-description "Result of compose." } ; { $class-description "Result of compose." } ;
HELP: input-parameter HELP: input-parameter

View File

@ -55,37 +55,37 @@ M: literal-tuple (literal) ;
[ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
literal-tuple boa ; inline literal-tuple boa ; inline
TUPLE: curried obj quot ; TUPLE: curried-effect obj quot ;
C: <curried> curried C: <curried-effect> curried-effect
: >curried< ( curried -- obj quot ) : >curried-effect< ( curried-effect -- obj quot )
[ obj>> ] [ quot>> ] bi ; inline [ obj>> ] [ quot>> ] bi ; inline
M: curried (input-value?) M: curried-effect (input-value?)
>curried< [ input-value? ] either? ; >curried-effect< [ input-value? ] either? ;
M: curried (literal-value?) M: curried-effect (literal-value?)
>curried< [ literal-value? ] both? ; >curried-effect< [ literal-value? ] both? ;
M: curried (literal) M: curried-effect (literal)
>curried< [ curry ] curried/composed-literal ; >curried-effect< [ curry ] curried/composed-literal ;
TUPLE: composed quot1 quot2 ; TUPLE: composed-effect quot1 quot2 ;
C: <composed> composed C: <composed-effect> composed-effect
: >composed< ( composed -- quot1 quot2 ) : >composed-effect< ( composed-effect -- quot1 quot2 )
[ quot1>> ] [ quot2>> ] bi ; inline [ quot1>> ] [ quot2>> ] bi ; inline
M: composed (input-value?) M: composed-effect (input-value?)
>composed< [ input-value? ] either? ; >composed-effect< [ input-value? ] either? ;
M: composed (literal-value?) M: composed-effect (literal-value?)
>composed< [ literal-value? ] both? ; >composed-effect< [ literal-value? ] both? ;
M: composed (literal) M: composed-effect (literal)
>composed< [ compose ] curried/composed-literal ; >composed-effect< [ compose ] curried/composed-literal ;
SINGLETON: input-parameter SINGLETON: input-parameter
@ -128,11 +128,11 @@ M: object known>callable drop \ _ ;
M: literal-tuple known>callable value>> ; M: literal-tuple known>callable value>> ;
M: composed known>callable M: composed-effect known>callable
>composed< [ known known>callable ?@ ] bi@ append ; >composed-effect< [ known known>callable ?@ ] bi@ append ;
M: curried known>callable M: curried-effect known>callable
>curried< [ known known>callable ] bi@ swap prefix ; >curried-effect< [ known known>callable ] bi@ swap prefix ;
M: declared-effect known>callable M: declared-effect known>callable
known>> known>callable ; known>> known>callable ;

View File

@ -278,49 +278,48 @@ slots>tuple 1quotation ( -- value ) define-inline
slots>tuple 1quotation ( -- value ) define-inline slots>tuple 1quotation ( -- value ) define-inline
! Some tuple classes ! Some tuple classes
"curry" "kernel" create-word
"curried" "kernel" create-word
tuple tuple
{ {
{ "obj" read-only } { "obj" read-only }
{ "quot" read-only } { "quot" read-only }
} prepare-slots define-tuple-class } prepare-slots define-tuple-class
"curry" "kernel" lookup-word "curry" "kernel" create-word
{ {
[ f "inline" set-word-prop ] [ f "inline" set-word-prop ]
[ make-flushable ] [ make-flushable ]
[ ]
[
[
callable instance-check-quot %
tuple-layout ,
\ <tuple-boa> ,
] [ ] make
]
} cleave } cleave
"curry" "kernel" lookup-word
[
callable instance-check-quot %
"curried" "kernel" lookup-word tuple-layout ,
\ <tuple-boa> ,
] [ ] make
( obj quot -- curry ) define-declared ( obj quot -- curry ) define-declared
"compose" "kernel" create-word "composed" "kernel" create-word
tuple tuple
{ {
{ "first" read-only } { "first" read-only }
{ "second" read-only } { "second" read-only }
} prepare-slots define-tuple-class } prepare-slots define-tuple-class
"compose" "kernel" lookup-word "compose" "kernel" create-word
{ {
[ f "inline" set-word-prop ] [ f "inline" set-word-prop ]
[ make-flushable ] [ make-flushable ]
[ ] } cleave
[
[ "compose" "kernel" lookup-word
[
callable instance-check-quot [ dip ] curry % callable instance-check-quot [ dip ] curry %
callable instance-check-quot % callable instance-check-quot %
tuple-layout , "composed" "kernel" lookup-word tuple-layout ,
\ <tuple-boa> , \ <tuple-boa> ,
] [ ] make ] [ ] make
]
} cleave
( quot1 quot2 -- compose ) define-declared ( quot1 quot2 -- compose ) define-declared
"* Declaring primitives..." print flush "* Declaring primitives..." print flush

View File

@ -17,23 +17,23 @@ PRIMITIVE: quotation-compiled? ( quot -- ? )
PRIMITIVE: array>quotation ( array -- quot ) PRIMITIVE: array>quotation ( array -- quot )
: uncurry ( curry -- obj quot ) : uncurry ( curry -- obj quot )
{ curry } declare dup 2 slot swap 3 slot ; inline { curried } declare dup 2 slot swap 3 slot ; inline
: uncompose ( compose -- quot quot2 ) : uncompose ( compose -- quot quot2 )
{ compose } declare dup 2 slot swap 3 slot ; inline { composed } declare dup 2 slot swap 3 slot ; inline
PRIVATE> PRIVATE>
M: quotation call (call) ; M: quotation call (call) ;
M: curry call uncurry call ; M: curried call uncurry call ;
M: compose call uncompose [ call ] dip call ; M: composed call uncompose [ call ] dip call ;
M: wrapper equal? M: wrapper equal?
over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ; over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
UNION: callable quotation curry compose ; UNION: callable quotation curried composed ;
M: callable equal? M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ; over callable? [ sequence= ] [ 2drop f ] if ;
@ -57,26 +57,26 @@ M: object literalize ;
M: wrapper literalize <wrapper> ; M: wrapper literalize <wrapper> ;
M: curry length quot>> length 1 + ; M: curried length quot>> length 1 + ;
M: curry nth M: curried nth
over 0 = over 0 =
[ nip obj>> literalize ] [ nip obj>> literalize ]
[ [ 1 - ] dip quot>> nth ] [ [ 1 - ] dip quot>> nth ]
if ; if ;
INSTANCE: curry immutable-sequence INSTANCE: curried immutable-sequence
M: compose length M: composed length
[ first>> length ] [ second>> length ] bi + ; [ first>> length ] [ second>> length ] bi + ;
M: compose virtual-exemplar first>> ; M: composed virtual-exemplar first>> ;
M: compose virtual@ M: composed virtual@
2dup first>> length < [ 2dup first>> length < [
first>> first>>
] [ ] [
[ first>> length - ] [ second>> ] bi [ first>> length - ] [ second>> ] bi
] if ; ] if ;
INSTANCE: compose virtual-sequence INSTANCE: composed virtual-sequence

View File

@ -253,8 +253,8 @@ CONSTANT: vpri-slides
{ { $link quotation } ", " { $link curry } " and " { $link compose } " are classes" } { { $link quotation } ", " { $link curry } " and " { $link compose } " are classes" }
{ $code { $code
"GENERIC: call ( quot -- )" "GENERIC: call ( quot -- )"
"M: curry call uncurry call ;" "M: curried call uncurry call ;"
"M: compose call uncompose slip call ;" "M: composed call uncompose slip call ;"
"M: quotation call (call) ;" "M: quotation call (call) ;"
} }
{ "So " { $link curry } ", " { $link compose } " are library features" } { "So " { $link curry } ", " { $link compose } " are library features" }

View File

@ -53,7 +53,7 @@ syn match factorCallQuotation /\<call(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ con
syn match factorExecute /\<execute(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ contained contains=factorStackEffect syn match factorExecute /\<execute(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ contained contains=factorStackEffect
syn keyword factorCallNextMethod call-next-method syn keyword factorCallNextMethod call-next-method
syn keyword factorKeyword (clone) -rot 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2nip 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3tri 4dip 4drop 4dup 4keep <wrapper> = >boolean ? ?if and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose compose? curry curry? die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep loop most new nip not null object or over pick prepose rot same? swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuple tuple? unless unless* until when when* while with wrapper wrapper? xor syn keyword factorKeyword (clone) -rot 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2nip 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3tri 4dip 4drop 4dup 4keep <wrapper> = >boolean ? ?if and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose composed? curry curried? die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep loop most new nip not null object or over pick prepose rot same? swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuple tuple? unless unless* until when when* while with wrapper wrapper? xor
syn keyword factorKeyword 2cache <enum> >alist ?at ?of assoc assoc-all? assoc-any? assoc-clone-like assoc-combine assoc-diff assoc-diff! assoc-differ assoc-each assoc-empty? assoc-filter assoc-filter! assoc-filter-as assoc-find assoc-hashcode assoc-intersect assoc-like assoc-map assoc-map-as assoc-partition assoc-refine assoc-reject assoc-reject! assoc-reject-as assoc-size assoc-stack assoc-subset? assoc-union assoc-union! assoc= assoc>map assoc? at at* at+ cache change-at clear-assoc delete-at delete-at* enum enum? extract-keys harvest-keys harvest-values inc-at key? keys map>alist map>assoc maybe-set-at new-assoc of push-at rename-at set-at sift-keys sift-values substitute unzip value-at value-at* value? values zip zip-as zip-index zip-index-as syn keyword factorKeyword 2cache <enum> >alist ?at ?of assoc assoc-all? assoc-any? assoc-clone-like assoc-combine assoc-diff assoc-diff! assoc-differ assoc-each assoc-empty? assoc-filter assoc-filter! assoc-filter-as assoc-find assoc-hashcode assoc-intersect assoc-like assoc-map assoc-map-as assoc-partition assoc-refine assoc-reject assoc-reject! assoc-reject-as assoc-size assoc-stack assoc-subset? assoc-union assoc-union! assoc= assoc>map assoc? at at* at+ cache change-at clear-assoc delete-at delete-at* enum enum? extract-keys harvest-keys harvest-values inc-at key? keys map>alist map>assoc maybe-set-at new-assoc of push-at rename-at set-at sift-keys sift-values substitute unzip value-at value-at* value? values zip zip-as zip-index zip-index-as
syn keyword factorKeyword 2cleave 2cleave>quot 3cleave 3cleave>quot 4cleave 4cleave>quot alist>quot call-effect case case-find case>quot cleave cleave>quot cond cond>quot deep-spread>quot execute-effect linear-case-quot no-case no-case? no-cond no-cond? recursive-hashcode shallow-spread>quot spread to-fixed-point wrong-values wrong-values? syn keyword factorKeyword 2cleave 2cleave>quot 3cleave 3cleave>quot 4cleave 4cleave>quot alist>quot call-effect case case-find case>quot cleave cleave>quot cond cond>quot deep-spread>quot execute-effect linear-case-quot no-case no-case? no-cond no-cond? recursive-hashcode shallow-spread>quot spread to-fixed-point wrong-values wrong-values?
syn keyword factorKeyword (all-integers?) (each-integer) (find-integer) * + - / /f /i /mod 2/ 2^ < <= <fp-nan> > >= >bignum >fixnum >float >fraction >integer >rect ?1+ abs align all-integers? bignum bignum? bit? bitand bitnot bitor bits>double bits>float bitxor complex complex? denominator double>bits each-integer even? fast-gcd find-integer find-last-integer fixnum fixnum? float float>bits float? fp-bitwise= fp-infinity? fp-nan-payload fp-nan? fp-qnan? fp-sign fp-snan? fp-special? gcd if-zero imaginary-part integer integer>fixnum integer>fixnum-strict integer? log2 log2-expects-positive log2-expects-positive? mod neg neg? next-float next-power-of-2 number number= number? numerator odd? power-of-2? prev-float ratio ratio? rational rational? real real-part real? recip rect> rem sgn shift sq times u< u<= u> u>= unless-zero unordered? when-zero zero? syn keyword factorKeyword (all-integers?) (each-integer) (find-integer) * + - / /f /i /mod 2/ 2^ < <= <fp-nan> > >= >bignum >fixnum >float >fraction >integer >rect ?1+ abs align all-integers? bignum bignum? bit? bitand bitnot bitor bits>double bits>float bitxor complex complex? denominator double>bits each-integer even? fast-gcd find-integer find-last-integer fixnum fixnum? float float>bits float? fp-bitwise= fp-infinity? fp-nan-payload fp-nan? fp-qnan? fp-sign fp-snan? fp-special? gcd if-zero imaginary-part integer integer>fixnum integer>fixnum-strict integer? log2 log2-expects-positive log2-expects-positive? mod neg neg? next-float next-power-of-2 number number= number? numerator odd? power-of-2? prev-float ratio ratio? rational rational? real real-part real? recip rect> rem sgn shift sq times u< u<= u> u>= unless-zero unordered? when-zero zero?