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
parent
1dc65c13e7
commit
32710df620
|
|
@ -48,7 +48,7 @@ gc
|
|||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
curried? composed? callable?
|
||||
quotation?
|
||||
|
||||
curry compose uncurry
|
||||
|
|
|
|||
|
|
@ -33,14 +33,14 @@ IDENTITY-MEMO: inputs/outputs ( quot -- in out )
|
|||
] if*
|
||||
] "special" set-word-prop
|
||||
|
||||
M: curried infer-known*
|
||||
M: curried-effect infer-known*
|
||||
quot>> infer-known dup [
|
||||
curry-effect
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
M: composed infer-known*
|
||||
M: composed-effect infer-known*
|
||||
[ quot1>> ] [ quot2>> ] bi
|
||||
[ infer-known ] bi@
|
||||
2dup and [ compose-effects ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ M: +unknown+ curry-effect* ;
|
|||
|
||||
M: effect curry-effect* curry-effect ;
|
||||
|
||||
M: curry cached-effect
|
||||
M: curried cached-effect
|
||||
quot>> cached-effect curry-effect* ;
|
||||
|
||||
: compose-effects* ( effect1 effect2 -- effect' )
|
||||
|
|
@ -37,9 +37,6 @@ M: curry cached-effect
|
|||
{ [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
|
||||
} cond ;
|
||||
|
||||
M: compose cached-effect
|
||||
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
|
||||
|
||||
: safe-infer ( quot -- effect )
|
||||
error get-global error-continuation get-global
|
||||
[ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
|
||||
|
|
@ -111,9 +108,9 @@ M: quotation cached-effect
|
|||
|
||||
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? ]
|
||||
[ second>> already-inlined-quot? ] bi or ;
|
||||
|
||||
|
|
@ -121,9 +118,9 @@ M: quotation already-inlined-quot? already-inlined? ;
|
|||
|
||||
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 ]
|
||||
[ second>> add-quot-to-history ] bi ;
|
||||
|
||||
|
|
@ -149,8 +146,8 @@ ERROR: uninferable ;
|
|||
[ safe-infer dup +unknown+ = [ uninferable ] when ] tri
|
||||
] [
|
||||
dup class>> {
|
||||
{ \ curry [ slots>> third (infer-value) remove-effect-input ] }
|
||||
{ \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
|
||||
{ \ curried [ slots>> third (infer-value) remove-effect-input ] }
|
||||
{ \ composed [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
|
||||
[ uninferable ]
|
||||
} case
|
||||
] if ;
|
||||
|
|
@ -163,11 +160,11 @@ ERROR: uninferable ;
|
|||
literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
|
||||
] [
|
||||
dup class>> {
|
||||
{ \ curry [
|
||||
{ \ curried [
|
||||
slots>> third (value>quot)
|
||||
'[ [ obj>> ] [ quot>> @ ] bi ]
|
||||
] }
|
||||
{ \ compose [
|
||||
{ \ composed [
|
||||
slots>> last2 [ (value>quot) ] bi@
|
||||
'[ [ first>> @ ] [ second>> @ ] bi ]
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -211,8 +211,8 @@ M: tuple pprint*
|
|||
[ number>string "~" " more~" surround text ] when* ;
|
||||
|
||||
M: quotation pprint-delims drop \ [ \ ] ;
|
||||
M: curry pprint-delims drop \ [ \ ] ;
|
||||
M: compose pprint-delims drop \ [ \ ] ;
|
||||
M: curried pprint-delims drop \ [ \ ] ;
|
||||
M: composed pprint-delims drop \ [ \ ] ;
|
||||
M: array pprint-delims drop \ { \ } ;
|
||||
M: byte-array pprint-delims drop \ B{ \ } ;
|
||||
M: byte-vector pprint-delims drop \ BV{ \ } ;
|
||||
|
|
@ -274,8 +274,8 @@ M: byte-vector pprint* pprint-object ;
|
|||
|
||||
M: hashtable pprint*
|
||||
[ pprint-object ] with-extra-nesting-level ;
|
||||
M: curry pprint* pprint-object ;
|
||||
M: compose pprint* pprint-object ;
|
||||
M: curried pprint* pprint-object ;
|
||||
M: composed pprint* pprint-object ;
|
||||
M: hash-set pprint* pprint-object ;
|
||||
M: anonymous-union pprint* pprint-object ;
|
||||
M: anonymous-intersection pprint* pprint-object ;
|
||||
|
|
|
|||
|
|
@ -139,8 +139,8 @@ M: callable infer-branch
|
|||
|
||||
GENERIC: curried/composed? ( known -- ? )
|
||||
M: object curried/composed? drop f ;
|
||||
M: curried curried/composed? drop t ;
|
||||
M: composed curried/composed? drop t ;
|
||||
M: curried-effect curried/composed? drop t ;
|
||||
M: composed-effect curried/composed? drop t ;
|
||||
M: declared-effect curried/composed? known>> curried/composed? ;
|
||||
|
||||
: declare-if-effects ( -- )
|
||||
|
|
|
|||
|
|
@ -105,14 +105,14 @@ GENERIC: infer-call* ( value known -- )
|
|||
M: literal-tuple infer-call*
|
||||
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
|
||||
|
||||
M: curried infer-call*
|
||||
M: curried-effect infer-call*
|
||||
swap push-d
|
||||
[ uncurry ] infer-quot-here
|
||||
[ quot>> known pop-d [ set-known ] keep ]
|
||||
[ obj>> known pop-d [ set-known ] keep ] bi
|
||||
push-d (infer-call) ;
|
||||
|
||||
M: composed infer-call*
|
||||
M: composed-effect infer-call*
|
||||
swap push-d
|
||||
[ uncompose ] infer-quot-here
|
||||
[ 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
|
||||
[ 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
|
||||
|
||||
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
|
||||
: infer-compose ( -- ) [ <composed-effect> ] \ compose infer-builder ;
|
||||
|
||||
\ compose [ infer-compose ] "special" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: hashtables help.markup help.syntax math quotations sequences words ;
|
||||
IN: stack-checker.values
|
||||
|
||||
HELP: curried
|
||||
HELP: curried-effect
|
||||
{ $class-description "Result of curry." } ;
|
||||
|
||||
HELP: composed
|
||||
HELP: composed-effect
|
||||
{ $class-description "Result of compose." } ;
|
||||
|
||||
HELP: input-parameter
|
||||
|
|
|
|||
|
|
@ -55,37 +55,37 @@ M: literal-tuple (literal) ;
|
|||
[ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
|
||||
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
|
||||
|
||||
M: curried (input-value?)
|
||||
>curried< [ input-value? ] either? ;
|
||||
M: curried-effect (input-value?)
|
||||
>curried-effect< [ input-value? ] either? ;
|
||||
|
||||
M: curried (literal-value?)
|
||||
>curried< [ literal-value? ] both? ;
|
||||
M: curried-effect (literal-value?)
|
||||
>curried-effect< [ literal-value? ] both? ;
|
||||
|
||||
M: curried (literal)
|
||||
>curried< [ curry ] curried/composed-literal ;
|
||||
M: curried-effect (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
|
||||
|
||||
M: composed (input-value?)
|
||||
>composed< [ input-value? ] either? ;
|
||||
M: composed-effect (input-value?)
|
||||
>composed-effect< [ input-value? ] either? ;
|
||||
|
||||
M: composed (literal-value?)
|
||||
>composed< [ literal-value? ] both? ;
|
||||
M: composed-effect (literal-value?)
|
||||
>composed-effect< [ literal-value? ] both? ;
|
||||
|
||||
M: composed (literal)
|
||||
>composed< [ compose ] curried/composed-literal ;
|
||||
M: composed-effect (literal)
|
||||
>composed-effect< [ compose ] curried/composed-literal ;
|
||||
|
||||
SINGLETON: input-parameter
|
||||
|
||||
|
|
@ -128,11 +128,11 @@ M: object known>callable drop \ _ ;
|
|||
|
||||
M: literal-tuple known>callable value>> ;
|
||||
|
||||
M: composed known>callable
|
||||
>composed< [ known known>callable ?@ ] bi@ append ;
|
||||
M: composed-effect known>callable
|
||||
>composed-effect< [ known known>callable ?@ ] bi@ append ;
|
||||
|
||||
M: curried known>callable
|
||||
>curried< [ known known>callable ] bi@ swap prefix ;
|
||||
M: curried-effect known>callable
|
||||
>curried-effect< [ known known>callable ] bi@ swap prefix ;
|
||||
|
||||
M: declared-effect known>callable
|
||||
known>> known>callable ;
|
||||
|
|
|
|||
|
|
@ -278,49 +278,48 @@ slots>tuple 1quotation ( -- value ) define-inline
|
|||
slots>tuple 1quotation ( -- value ) define-inline
|
||||
|
||||
! Some tuple classes
|
||||
"curry" "kernel" create-word
|
||||
|
||||
"curried" "kernel" create-word
|
||||
tuple
|
||||
{
|
||||
{ "obj" read-only }
|
||||
{ "quot" read-only }
|
||||
} prepare-slots define-tuple-class
|
||||
|
||||
"curry" "kernel" lookup-word
|
||||
"curry" "kernel" create-word
|
||||
{
|
||||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[
|
||||
[
|
||||
callable instance-check-quot %
|
||||
tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
] [ ] make
|
||||
]
|
||||
} cleave
|
||||
|
||||
"curry" "kernel" lookup-word
|
||||
[
|
||||
callable instance-check-quot %
|
||||
"curried" "kernel" lookup-word tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
] [ ] make
|
||||
( obj quot -- curry ) define-declared
|
||||
|
||||
"compose" "kernel" create-word
|
||||
"composed" "kernel" create-word
|
||||
tuple
|
||||
{
|
||||
{ "first" read-only }
|
||||
{ "second" read-only }
|
||||
} prepare-slots define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup-word
|
||||
"compose" "kernel" create-word
|
||||
{
|
||||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[
|
||||
[
|
||||
} cleave
|
||||
|
||||
"compose" "kernel" lookup-word
|
||||
[
|
||||
callable instance-check-quot [ dip ] curry %
|
||||
callable instance-check-quot %
|
||||
tuple-layout ,
|
||||
"composed" "kernel" lookup-word tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
] [ ] make
|
||||
]
|
||||
} cleave
|
||||
] [ ] make
|
||||
( quot1 quot2 -- compose ) define-declared
|
||||
|
||||
"* Declaring primitives..." print flush
|
||||
|
|
|
|||
|
|
@ -17,23 +17,23 @@ PRIMITIVE: quotation-compiled? ( quot -- ? )
|
|||
PRIMITIVE: array>quotation ( array -- 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 )
|
||||
{ compose } declare dup 2 slot swap 3 slot ; inline
|
||||
{ composed } declare dup 2 slot swap 3 slot ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
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?
|
||||
over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
|
||||
|
||||
UNION: callable quotation curry compose ;
|
||||
UNION: callable quotation curried composed ;
|
||||
|
||||
M: callable equal?
|
||||
over callable? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
@ -57,26 +57,26 @@ M: object literalize ;
|
|||
|
||||
M: wrapper literalize <wrapper> ;
|
||||
|
||||
M: curry length quot>> length 1 + ;
|
||||
M: curried length quot>> length 1 + ;
|
||||
|
||||
M: curry nth
|
||||
M: curried nth
|
||||
over 0 =
|
||||
[ nip obj>> literalize ]
|
||||
[ [ 1 - ] dip quot>> nth ]
|
||||
if ;
|
||||
|
||||
INSTANCE: curry immutable-sequence
|
||||
INSTANCE: curried immutable-sequence
|
||||
|
||||
M: compose length
|
||||
M: composed length
|
||||
[ first>> length ] [ second>> length ] bi + ;
|
||||
|
||||
M: compose virtual-exemplar first>> ;
|
||||
M: composed virtual-exemplar first>> ;
|
||||
|
||||
M: compose virtual@
|
||||
M: composed virtual@
|
||||
2dup first>> length < [
|
||||
first>>
|
||||
] [
|
||||
[ first>> length - ] [ second>> ] bi
|
||||
] if ;
|
||||
|
||||
INSTANCE: compose virtual-sequence
|
||||
INSTANCE: composed virtual-sequence
|
||||
|
|
|
|||
|
|
@ -253,8 +253,8 @@ CONSTANT: vpri-slides
|
|||
{ { $link quotation } ", " { $link curry } " and " { $link compose } " are classes" }
|
||||
{ $code
|
||||
"GENERIC: call ( quot -- )"
|
||||
"M: curry call uncurry call ;"
|
||||
"M: compose call uncompose slip call ;"
|
||||
"M: curried call uncurry call ;"
|
||||
"M: composed call uncompose slip call ;"
|
||||
"M: quotation call (call) ;"
|
||||
}
|
||||
{ "So " { $link curry } ", " { $link compose } " are library features" }
|
||||
|
|
|
|||
|
|
@ -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 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 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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue