Also rename the stack-checker curried -> curried-effect, composed -> composed-effect.
array? hashtable? vector?
tuple? sbuf? tombstone?
- curry? compose? callable?
+ curried? composed? callable?
quotation?
curry compose uncurry
] 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 ;
M: effect curry-effect* curry-effect ;
-M: curry cached-effect
+M: curried cached-effect
quot>> cached-effect curry-effect* ;
: compose-effects* ( effect1 effect2 -- 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
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 ;
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 ;
[ 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 ;
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 ]
] }
[ 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{ \ } ;
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 ;
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 ( -- )
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 ]
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
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
[ [ [ 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
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 ;
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 ]
- [ ]
- [
- [
- callable instance-check-quot [ dip ] curry %
- callable instance-check-quot %
- tuple-layout ,
- \ <tuple-boa> ,
- ] [ ] make
- ]
} cleave
+
+"compose" "kernel" lookup-word
+[
+ callable instance-check-quot [ dip ] curry %
+ callable instance-check-quot %
+ "composed" "kernel" lookup-word tuple-layout ,
+ \ <tuple-boa> ,
+] [ ] make
( quot1 quot2 -- compose ) define-declared
"* Declaring primitives..." print flush
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 ;
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
{ { $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" }
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?
projects / factor.git / commitdiff