replace add* and add with prefix and suffix
parent
4181728eca
commit
aa40350aa7
|
@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
|
|||
|
||||
: parse-array-type ( name -- array )
|
||||
"[" split unclip
|
||||
>r [ "]" ?tail drop string>number ] map r> add* ;
|
||||
>r [ "]" ?tail drop string>number ] map r> prefix ;
|
||||
|
||||
M: string c-type ( name -- type )
|
||||
CHAR: ] over member? [
|
||||
|
@ -162,7 +162,7 @@ DEFER: >c-ushort-array
|
|||
>r >c-ushort-array r> byte-array>memory ;
|
||||
|
||||
: (define-nth) ( word type quot -- )
|
||||
>r heap-size [ rot * ] swap add* r> append define-inline ;
|
||||
>r heap-size [ rot * ] swap prefix r> append define-inline ;
|
||||
|
||||
: nth-word ( name vocab -- word )
|
||||
>r "-nth" append r> create ;
|
||||
|
@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
|
|||
f swap box-parameter ;
|
||||
|
||||
: define-deref ( name vocab -- )
|
||||
>r dup CHAR: * add* r> create
|
||||
swap c-getter 0 add* define-inline ;
|
||||
>r dup CHAR: * prefix r> create
|
||||
swap c-getter 0 prefix define-inline ;
|
||||
|
||||
: define-out ( name vocab -- )
|
||||
over [ <c-object> tuck 0 ] over c-setter append swap
|
||||
>r >r constructor-word r> r> add* define-inline ;
|
||||
>r >r constructor-word r> r> prefix define-inline ;
|
||||
|
||||
: c-bool> ( int -- ? )
|
||||
zero? not ;
|
||||
|
@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
|
|||
#! staging violations
|
||||
dup array? [
|
||||
unclip >r [ dup word? [ word-def call ] when ] map
|
||||
r> add*
|
||||
r> prefix
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
|
|
|
@ -18,7 +18,7 @@ IN: alien.compiler
|
|||
|
||||
: alien-node-parameters* ( node -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" add* ] when ;
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
|
||||
: alien-node-return* ( node -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
|
|
|
@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
|
|||
dup ?word-name swap 2array
|
||||
over slot-spec-name
|
||||
rot slot-spec-type 2array 2array
|
||||
[ { $instance } swap add ] assoc-map ;
|
||||
[ { $instance } swap suffix ] assoc-map ;
|
||||
|
||||
: $spec-reader-values ( slot-spec class -- )
|
||||
($spec-reader-values) $values ;
|
||||
|
@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
|
|||
: $spec-reader-description ( slot-spec class -- )
|
||||
[
|
||||
"Outputs the value stored in the " ,
|
||||
{ $snippet } rot slot-spec-name add ,
|
||||
{ $snippet } rot slot-spec-name suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap add ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
|
@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
|
|||
: $spec-writer-description ( slot-spec class -- )
|
||||
[
|
||||
"Stores a new value to the " ,
|
||||
{ $snippet } rot slot-spec-name add ,
|
||||
{ $snippet } rot slot-spec-name suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap add ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: alien.structs
|
|||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( spec word quot -- )
|
||||
rot slot-spec-offset add* define-inline ;
|
||||
rot slot-spec-offset prefix define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
|
|
|
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
members>> [ class-and ] with map <anonymous-union> ;
|
||||
|
||||
: left-anonymous-intersection-and ( first second -- class )
|
||||
>r members>> r> add <anonymous-intersection> ;
|
||||
>r members>> r> suffix <anonymous-intersection> ;
|
||||
|
||||
: right-anonymous-intersection-and ( first second -- class )
|
||||
members>> swap add <anonymous-intersection> ;
|
||||
members>> swap suffix <anonymous-intersection> ;
|
||||
|
||||
: (class-and) ( first second -- class )
|
||||
{
|
||||
|
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
} cond ;
|
||||
|
||||
: left-anonymous-union-or ( first second -- class )
|
||||
>r members>> r> add <anonymous-union> ;
|
||||
>r members>> r> suffix <anonymous-union> ;
|
||||
|
||||
: right-anonymous-union-or ( first second -- class )
|
||||
members>> swap add <anonymous-union> ;
|
||||
members>> swap suffix <anonymous-union> ;
|
||||
|
||||
: (class-or) ( first second -- class )
|
||||
{
|
||||
|
|
|
@ -72,7 +72,7 @@ M: word reset-class drop ;
|
|||
|
||||
! update-map
|
||||
: class-uses ( class -- seq )
|
||||
dup members swap superclass [ add ] when* ;
|
||||
dup members swap superclass [ suffix ] when* ;
|
||||
|
||||
: class-usages ( class -- assoc )
|
||||
[ update-map get at ] closure ;
|
||||
|
|
|
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
|
|||
swap redefine-mixin-class ; inline
|
||||
|
||||
: add-mixin-instance ( class mixin -- )
|
||||
[ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
|
||||
[ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
|
||||
|
||||
: remove-mixin-instance ( class mixin -- )
|
||||
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
|
||||
|
|
|
@ -34,7 +34,7 @@ PRIVATE>
|
|||
: tuple>array ( tuple -- array )
|
||||
dup tuple-layout
|
||||
[ layout-size swap [ array-nth ] curry map ] keep
|
||||
layout-class add* ;
|
||||
layout-class prefix ;
|
||||
|
||||
: >tuple ( seq -- tuple )
|
||||
dup first tuple-layout <tuple> [
|
||||
|
|
|
@ -43,7 +43,7 @@ ERROR: no-case ;
|
|||
: with-datastack ( stack quot -- newstack )
|
||||
datastack >r
|
||||
>r >array set-datastack r> call
|
||||
datastack r> swap add set-datastack 2nip ; inline
|
||||
datastack r> swap suffix set-datastack 2nip ; inline
|
||||
|
||||
: recursive-hashcode ( n obj quot -- code )
|
||||
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
|
||||
|
@ -66,7 +66,7 @@ M: hashtable hashcode*
|
|||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
|
||||
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
|
|
|
@ -230,7 +230,7 @@ UNION: operand register indirect ;
|
|||
|
||||
: opcode-or ( opcode mask -- opcode' )
|
||||
swap dup array?
|
||||
[ 1 cut* first rot bitor add ] [ bitor ] if ;
|
||||
[ 1 cut* first rot bitor suffix ] [ bitor ] if ;
|
||||
|
||||
: 1-operand ( op reg rex.w opcode -- )
|
||||
#! The 'reg' is not really a register, but a value for the
|
||||
|
|
|
@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics
|
|||
|
||||
! Fixnums
|
||||
: fixnum-op ( op hash -- pair )
|
||||
>r [ "x" operand "y" operand ] swap add r> 2array ;
|
||||
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
|
||||
|
||||
: fixnum-value-op ( op -- pair )
|
||||
H{
|
||||
|
@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics
|
|||
\ fixnum- \ SUB overflow-template
|
||||
|
||||
: fixnum-jump ( op inputs -- pair )
|
||||
>r [ "x" operand "y" operand CMP ] swap add r> 2array ;
|
||||
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
|
||||
|
||||
: fixnum-value-jump ( op -- pair )
|
||||
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
|
||||
|
|
|
@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
|
|||
IN: cpu.x86.sse2
|
||||
|
||||
: define-float-op ( word op -- )
|
||||
[ "x" operand "y" operand ] swap add H{
|
||||
[ "x" operand "y" operand ] swap suffix H{
|
||||
{ +input+ { { float "x" } { float "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
} define-intrinsic ;
|
||||
|
@ -23,7 +23,7 @@ IN: cpu.x86.sse2
|
|||
] each
|
||||
|
||||
: define-float-jump ( word op -- )
|
||||
[ "x" operand "y" operand UCOMISD ] swap add
|
||||
[ "x" operand "y" operand UCOMISD ] swap suffix
|
||||
{ { float "x" } { float "y" } } define-if-intrinsic ;
|
||||
|
||||
{
|
||||
|
|
|
@ -157,7 +157,7 @@ M: assoc update-methods ( assoc -- )
|
|||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add ;
|
||||
swap "default-method" word-prop suffix ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget ] each (forget-word) ;
|
||||
|
|
|
@ -34,8 +34,8 @@ ERROR: no-method object generic ;
|
|||
: empty-method ( word -- quot )
|
||||
[
|
||||
picker % [ delegate dup ] %
|
||||
unpicker over add ,
|
||||
error-method \ drop add* , \ if ,
|
||||
unpicker over suffix ,
|
||||
error-method \ drop prefix , \ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: class-predicates ( assoc -- assoc )
|
||||
|
@ -137,7 +137,7 @@ ERROR: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: standard-methods ( word -- alist )
|
||||
dup methods swap default-method add*
|
||||
dup methods swap default-method prefix
|
||||
[ 1quotation ] assoc-map ;
|
||||
|
||||
M: standard-combination make-default-method
|
||||
|
|
|
@ -92,7 +92,7 @@ M: wrapper apply-object
|
|||
r> recursive-state set ;
|
||||
|
||||
: infer-quot-recursive ( quot word label -- )
|
||||
recursive-state get -rot 2array add* infer-quot ;
|
||||
recursive-state get -rot 2array prefix infer-quot ;
|
||||
|
||||
: time-bomb ( error -- )
|
||||
[ throw ] curry recursive-state get infer-quot ;
|
||||
|
@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error quot ;
|
|||
dup value-literal callable? [
|
||||
dup value-literal
|
||||
over value-recursion
|
||||
rot f 2array add* infer-quot
|
||||
rot f 2array prefix infer-quot
|
||||
] [
|
||||
drop bad-call
|
||||
] if
|
||||
|
@ -430,7 +430,7 @@ M: #call-label collect-recursion*
|
|||
[ [ swap collect-recursion* ] curry each-node ] { } make ;
|
||||
|
||||
: join-values ( node -- )
|
||||
collect-recursion [ node-in-d ] map meta-d get add
|
||||
collect-recursion [ node-in-d ] map meta-d get suffix
|
||||
unify-lengths unify-stacks
|
||||
meta-d [ length tail* ] change ;
|
||||
|
||||
|
|
|
@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- )
|
|||
dup annotate-node
|
||||
dup infer-classes-before
|
||||
dup infer-children
|
||||
dup collect-recursion over add
|
||||
dup collect-recursion over suffix
|
||||
pick annotate-entry
|
||||
node-child (infer-classes) ;
|
||||
|
||||
|
|
|
@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ;
|
|||
2dup 2slip rot [
|
||||
2drop t
|
||||
] [
|
||||
>r dup node-children swap node-successor add r>
|
||||
>r dup node-children swap node-successor suffix r>
|
||||
[ node-exists? ] curry contains?
|
||||
] if
|
||||
] [
|
||||
|
|
|
@ -56,7 +56,7 @@ M: pair (bitfield-quot) ( spec -- quot )
|
|||
[ shift bitor ] append 2curry ;
|
||||
|
||||
: bitfield-quot ( spec -- quot )
|
||||
[ (bitfield-quot) ] map [ 0 ] add* concat ;
|
||||
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
|
||||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
|
|
|
@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
|
|||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
over stream-read1 [ add ] when*
|
||||
over stream-read1 [ suffix ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
|
|
|
@ -60,7 +60,7 @@ sequences.private combinators ;
|
|||
[ value-literal sequence? ] [ drop f ] if ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
|
||||
[ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
|
||||
|
||||
: expand-member ( #call -- )
|
||||
dup node-in-d peek value-literal member-quot f splice-quot ;
|
||||
|
|
|
@ -32,7 +32,7 @@ IN: optimizer.specializers
|
|||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop add* ;
|
||||
swap "method-class" word-prop prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration [ declare ] curry prepend ;
|
||||
|
|
|
@ -294,7 +294,7 @@ M: no-word-error summary
|
|||
scan {
|
||||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word ";" parse-tokens ] }
|
||||
[ >r tuple ";" parse-tokens r> add* ]
|
||||
[ >r tuple ";" parse-tokens r> prefix ]
|
||||
} case ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
|
|
@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
|
|||
>r create-method r> define ;
|
||||
|
||||
: define-slot-word ( class slot word quot -- )
|
||||
rot >fixnum add* define-typecheck ;
|
||||
rot >fixnum prefix define-typecheck ;
|
||||
|
||||
: reader-quot ( decl -- quot )
|
||||
[
|
||||
|
|
|
@ -76,5 +76,5 @@ INSTANCE: groups sequence
|
|||
1 head-slice* [
|
||||
"\r" ?tail drop "\r" split
|
||||
] map
|
||||
] keep peek "\r" split add concat
|
||||
] keep peek "\r" split suffix concat
|
||||
] if ;
|
||||
|
|
|
@ -20,7 +20,7 @@ V{
|
|||
|
||||
: vocab-dir+ ( vocab str/f -- path )
|
||||
>r vocab-name "." split r>
|
||||
[ >r dup peek r> append add ] when*
|
||||
[ >r dup peek r> append suffix ] when*
|
||||
"/" join ;
|
||||
|
||||
: vocab-dir? ( root name -- ? )
|
||||
|
|
|
@ -82,7 +82,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
|
|||
|
||||
: child-vocab? ( prefix name -- ? )
|
||||
2dup = pick empty? or
|
||||
[ 2drop t ] [ swap CHAR: . add head? ] if ;
|
||||
[ 2drop t ] [ swap CHAR: . suffix head? ] if ;
|
||||
|
||||
: child-vocabs ( vocab -- seq )
|
||||
vocab-name vocabs [ child-vocab? ] with subset ;
|
||||
|
|
|
@ -49,7 +49,7 @@ HINTS: random fixnum ;
|
|||
|
||||
: make-cumulative ( freq -- chars floats )
|
||||
dup keys >byte-array
|
||||
swap values >float-array unclip [ + ] accumulate swap add ;
|
||||
swap values >float-array unclip [ + ] accumulate swap suffix ;
|
||||
|
||||
:: select-random ( seed chars floats -- seed elt )
|
||||
floats seed random -rot
|
||||
|
|
|
@ -32,7 +32,7 @@ VAR: color
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
|
||||
: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
|
||||
|
||||
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@ M: color-preview model-changed
|
|||
swap model-value over set-gadget-interior relayout-1 ;
|
||||
|
||||
: <color-model> ( model -- model )
|
||||
[ [ 256 /f ] map 1 add <solid> ] <filter> ;
|
||||
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
|
||||
|
||||
: <color-sliders> ( -- model gadget )
|
||||
3 [ drop 0 0 0 255 <range> ] map
|
||||
|
|
|
@ -27,7 +27,7 @@ M: tuple-class group-words
|
|||
swap [ slot-spec-writer ] map append ;
|
||||
|
||||
: define-consult-method ( word class quot -- )
|
||||
pick add >r swap create-method r> define ;
|
||||
pick suffix >r swap create-method r> define ;
|
||||
|
||||
: define-consult ( class group quot -- )
|
||||
>r group-words swap r>
|
||||
|
|
|
@ -43,7 +43,7 @@ SYMBOL: edit-hook
|
|||
|
||||
: fix ( word -- )
|
||||
"Fixing " write dup pprint " and all usages..." print nl
|
||||
dup usage swap add* [
|
||||
dup usage swap prefix [
|
||||
"Editing " write dup .
|
||||
"RETURN moves on to the next usage, C+d stops." print
|
||||
flush
|
||||
|
|
|
@ -69,7 +69,7 @@ C: <faq> faq
|
|||
|
||||
: html>faq ( div -- faq )
|
||||
unclip swap { "h3" "ol" } [ tags-named ] with map
|
||||
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
|
||||
first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
|
||||
|
||||
: header, ( faq -- )
|
||||
dup faq-header ,
|
||||
|
|
|
@ -28,7 +28,7 @@ DEFER: (fry)
|
|||
! to avoid confusion, remove if fry goes core
|
||||
{ namespaces:, [ [ curry ] ((fry)) ] }
|
||||
|
||||
[ swap >r add r> (fry) ]
|
||||
[ swap >r suffix r> (fry) ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -235,7 +235,7 @@ M: string ($instance)
|
|||
|
||||
: values-row ( seq -- seq )
|
||||
unclip \ $snippet swap ?word-name 2array
|
||||
swap dup first word? [ \ $instance add* ] when 2array ;
|
||||
swap dup first word? [ \ $instance prefix ] when 2array ;
|
||||
|
||||
: $values ( element -- )
|
||||
"Inputs and outputs" $heading
|
||||
|
|
|
@ -184,7 +184,7 @@ DEFER: (d)
|
|||
[ length ] keep [ (graded-ker/im-d) ] curry map ;
|
||||
|
||||
: graded-betti ( generators -- seq )
|
||||
basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ;
|
||||
basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
|
||||
|
||||
! Bi-graded for two-step complexes
|
||||
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
|
||||
|
@ -203,7 +203,7 @@ DEFER: (d)
|
|||
[ basis graded ] bi@ tensor bigraded-ker/im-d
|
||||
[ [ [ first ] map ] map ] keep
|
||||
[ [ second ] map 2 head* { 0 0 } prepend ] map
|
||||
1 tail dup first length 0 <array> add
|
||||
1 tail dup first length 0 <array> suffix
|
||||
[ v- ] 2map ;
|
||||
|
||||
! Laplacian
|
||||
|
|
|
@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool )
|
|||
drop nil
|
||||
] [
|
||||
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
|
||||
swap [ swap [ add ] lmap-with ] lmap-with lconcat
|
||||
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
|
||||
] reduce
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ;
|
|||
: point-free-end ( quot args -- newquot )
|
||||
over peek special?
|
||||
[ drop-locals >r >r peek r> localize r> append ]
|
||||
[ drop-locals nip swap peek add ]
|
||||
[ drop-locals nip swap peek suffix ]
|
||||
if ;
|
||||
|
||||
: (point-free) ( quot args -- newquot )
|
||||
|
@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars )
|
|||
|
||||
: add-if-free ( vars object -- vars )
|
||||
{
|
||||
{ [ dup local-writer? ] [ "local-reader" word-prop add ] }
|
||||
{ [ dup lexical? ] [ add ] }
|
||||
{ [ dup quote? ] [ quote-local add ] }
|
||||
{ [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
|
||||
{ [ dup lexical? ] [ suffix ] }
|
||||
{ [ dup quote? ] [ quote-local suffix ] }
|
||||
{ [ t ] [ free-vars append ] }
|
||||
} cond ;
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ SYMBOL: CRITICAL
|
|||
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
|
||||
: send-to-log-server ( array string -- )
|
||||
add* "log-server" get send ;
|
||||
prefix "log-server" get send ;
|
||||
|
||||
SYMBOL: log-service
|
||||
|
||||
|
|
|
@ -77,7 +77,7 @@ VAR: color-table
|
|||
{ 0.25 0.25 0.25 } ! dark grey
|
||||
{ 0.75 0.75 0.75 } ! medium grey
|
||||
{ 1 1 1 } ! white
|
||||
} [ 1 add ] map >color-table ;
|
||||
} [ 1 suffix ] map >color-table ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -18,7 +18,7 @@ IN: math.combinatorics
|
|||
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
|
||||
|
||||
: (>permutation) ( seq n -- seq )
|
||||
[ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
|
||||
[ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
|
||||
|
||||
: >permutation ( factoradic -- permutation )
|
||||
reverse 1 cut [ (>permutation) ] each ;
|
||||
|
|
|
@ -191,14 +191,14 @@ M: hook-combination generic-prologue
|
|||
[ delete-at ] with-methods ;
|
||||
|
||||
: method>spec ( method -- spec )
|
||||
dup method-classes swap method-generic add* ;
|
||||
dup method-classes swap method-generic prefix ;
|
||||
|
||||
: parse-method ( -- quot classes generic )
|
||||
parse-definition dup 2 tail over second rot first ;
|
||||
|
||||
: METHOD:
|
||||
location
|
||||
>r parse-method [ define-method ] 2keep add* r>
|
||||
>r parse-method [ define-method ] 2keep prefix r>
|
||||
remember-definition ; parsing
|
||||
|
||||
! For compatibility
|
||||
|
|
|
@ -38,7 +38,7 @@ reset-gl-function-number-counter
|
|||
gl-function-calling-convention
|
||||
scan
|
||||
scan dup
|
||||
scan drop "}" parse-tokens swap add*
|
||||
scan drop "}" parse-tokens swap prefix
|
||||
gl-function-number
|
||||
[ gl-function-pointer ] 2curry swap
|
||||
";" parse-tokens [ "()" subseq? not ] subset
|
||||
|
|
|
@ -236,13 +236,13 @@ C: <connection> connection
|
|||
|
||||
: fetch-each ( object -- object )
|
||||
fetch-statement [
|
||||
buf get alien>char-string res get swap add res set
|
||||
buf get alien>char-string res get swap suffix res set
|
||||
fetch-each
|
||||
] [ ] if ;
|
||||
|
||||
: run-query ( object -- object )
|
||||
execute-statement [
|
||||
buf get alien>char-string res get swap add res set
|
||||
buf get alien>char-string res get swap suffix res set
|
||||
fetch-each
|
||||
] [ ] if ;
|
||||
|
||||
|
|
|
@ -132,7 +132,7 @@ TUPLE: and-parser parsers ;
|
|||
|
||||
: <&> ( parser1 parser2 -- parser )
|
||||
over and-parser? [
|
||||
>r and-parser-parsers r> add
|
||||
>r and-parser-parsers r> suffix
|
||||
] [
|
||||
2array
|
||||
] if and-parser construct-boa ;
|
||||
|
@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result )
|
|||
|
||||
: <:&> ( parser1 parser2 -- result )
|
||||
#! Same as <&> except flatten the result.
|
||||
<&> [ first2 add ] <@ ;
|
||||
<&> [ first2 suffix ] <@ ;
|
||||
|
||||
: <&:> ( parser1 parser2 -- result )
|
||||
#! Same as <&> except flatten the result.
|
||||
<&> [ first2 swap add* ] <@ ;
|
||||
<&> [ first2 swap prefix ] <@ ;
|
||||
|
||||
: <:&:> ( parser1 parser2 -- result )
|
||||
#! Same as <&> except flatten the result.
|
||||
|
|
|
@ -104,7 +104,7 @@ C: <head> peg-head
|
|||
:: (setup-lr) ( r l s -- )
|
||||
s head>> l head>> eq? [
|
||||
l head>> s (>>head)
|
||||
l head>> [ s rule>> add ] change-involved-set drop
|
||||
l head>> [ s rule>> suffix ] change-involved-set drop
|
||||
r l s next>> (setup-lr)
|
||||
] unless ;
|
||||
|
||||
|
@ -136,7 +136,7 @@ C: <head> peg-head
|
|||
h [ p heads get at ]
|
||||
|
|
||||
h [
|
||||
m r h involved-set>> h rule>> add member? not and [
|
||||
m r h involved-set>> h rule>> suffix member? not and [
|
||||
fail p <memo-entry>
|
||||
] [
|
||||
r h eval-set>> member? [
|
||||
|
|
|
@ -76,10 +76,10 @@ PRIVATE>
|
|||
dup first 2 tail* swap second 2 head = ;
|
||||
|
||||
: clean ( seq -- seq )
|
||||
[ unclip 1 head add* concat ] map [ all-unique? ] subset ;
|
||||
[ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
|
||||
|
||||
: add-missing-digit ( seq -- seq )
|
||||
dup natural-sort 10 seq-diff first add* ;
|
||||
dup natural-sort 10 seq-diff first prefix ;
|
||||
|
||||
: interesting-pandigitals ( -- seq )
|
||||
17 candidates { 13 11 7 5 3 2 } [
|
||||
|
|
|
@ -72,7 +72,7 @@ PRIVATE>
|
|||
|
||||
: max-path ( triangle -- n )
|
||||
dup length 1 > [
|
||||
2 cut* first2 max-children [ + ] 2map add max-path
|
||||
2 cut* first2 max-children [ + ] 2map suffix max-path
|
||||
] [
|
||||
first first
|
||||
] if ;
|
||||
|
@ -95,7 +95,7 @@ PRIVATE>
|
|||
! Not strictly needed, but it is nice to be able to dump the triangle after the
|
||||
! propagation
|
||||
: propagate-all ( triangle -- newtriangle )
|
||||
reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
|
||||
reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ;
|
||||
|
||||
: sum-divisors ( n -- sum )
|
||||
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: qualified
|
|||
|
||||
: define-qualified ( vocab-name -- )
|
||||
dup require
|
||||
dup vocab-words swap CHAR: : add
|
||||
dup vocab-words swap CHAR: : suffix
|
||||
[ -rot >r append r> ] curry assoc-map
|
||||
use get push ;
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@ SYMBOL: ignore-case?
|
|||
if 2curry ;
|
||||
|
||||
: or-predicates ( quots -- quot )
|
||||
[ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
|
||||
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
|
||||
|
||||
: <@literal [ nip ] curry <@ ;
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@ SYMBOL: ignore-case?
|
|||
if 2curry ;
|
||||
|
||||
: or-predicates ( quots -- quot )
|
||||
[ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
|
||||
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
|
||||
|
||||
: literal-action [ nip ] curry action ;
|
||||
|
||||
|
|
|
@ -94,7 +94,7 @@ MACRO: firstn ( n -- )
|
|||
|
||||
: monotonic-split ( seq quot -- newseq )
|
||||
[
|
||||
>r dup unclip add r>
|
||||
>r dup unclip suffix r>
|
||||
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
|
||||
] { } make ;
|
||||
|
||||
|
|
|
@ -235,7 +235,7 @@ C: <spring> spring
|
|||
6 nrot 6 nrot 2array
|
||||
5 nrot 5 nrot 2array
|
||||
0 0 2array <node>
|
||||
nodes> swap add >nodes ;
|
||||
nodes> swap suffix >nodes ;
|
||||
|
||||
: spng ( id id-a id-b k damp rest-length -- )
|
||||
6 nrot drop
|
||||
|
@ -243,4 +243,4 @@ C: <spring> spring
|
|||
5 nrot node-id
|
||||
5 nrot node-id
|
||||
<spring>
|
||||
springs> swap add >springs ;
|
||||
springs> swap suffix >springs ;
|
||||
|
|
|
@ -6,7 +6,7 @@ IN: state-machine
|
|||
! STATES: set-name state1 state2 ... ;
|
||||
";" parse-tokens
|
||||
[ length ] keep
|
||||
unclip add
|
||||
unclip suffix
|
||||
[ create-in swap 1quotation define ] 2each ; parsing
|
||||
|
||||
TUPLE: state place data ;
|
||||
|
|
|
@ -37,7 +37,7 @@ TUPLE: board width height rows ;
|
|||
|
||||
: add-row ( board -- )
|
||||
dup board-rows over board-width f <array>
|
||||
add* swap set-board-rows ;
|
||||
prefix swap set-board-rows ;
|
||||
|
||||
: top-up-rows ( board -- )
|
||||
dup board-height over board-rows length = [
|
||||
|
|
|
@ -46,7 +46,7 @@ IN: tools.deploy.backend
|
|||
|
||||
: staging-image-name ( profile -- name )
|
||||
"staging."
|
||||
swap strip-word-names? [ "strip" add ] when
|
||||
swap strip-word-names? [ "strip" suffix ] when
|
||||
"-" join ".image" 3append temp-file ;
|
||||
|
||||
DEFER: ?make-staging-image
|
||||
|
@ -75,7 +75,7 @@ DEFER: ?make-staging-image
|
|||
] { } make ;
|
||||
|
||||
: run-factor ( vm flags -- )
|
||||
swap add* dup . run-with-output ; inline
|
||||
swap prefix dup . run-with-output ; inline
|
||||
|
||||
: make-staging-image ( profile -- )
|
||||
vm swap staging-command-line run-factor ;
|
||||
|
|
|
@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
try-everything load-failures. ;
|
||||
|
||||
: unrooted-child-vocabs ( prefix -- seq )
|
||||
dup empty? [ CHAR: . add ] unless
|
||||
dup empty? [ CHAR: . suffix ] unless
|
||||
vocabs
|
||||
[ find-vocab-root not ] subset
|
||||
[
|
||||
|
@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
vocab-roots get [
|
||||
dup pick (all-child-vocabs) [ >vocab-link ] map
|
||||
] { } map>assoc
|
||||
swap unrooted-child-vocabs f swap 2array add ;
|
||||
swap unrooted-child-vocabs f swap 2array suffix ;
|
||||
|
||||
: all-child-vocabs-seq ( prefix -- assoc )
|
||||
vocab-roots get swap [
|
||||
|
|
|
@ -49,10 +49,10 @@ DEFER: start-walker-thread
|
|||
\ break t "break?" set-word-prop
|
||||
|
||||
: walk ( quot -- quot' )
|
||||
\ break add* [ break rethrow ] recover ;
|
||||
\ break prefix [ break rethrow ] recover ;
|
||||
|
||||
: add-breakpoint ( quot -- quot' )
|
||||
dup [ break ] head? [ \ break add* ] unless ;
|
||||
dup [ break ] head? [ \ break prefix ] unless ;
|
||||
|
||||
: (step-into-quot) ( quot -- ) add-breakpoint call ;
|
||||
|
||||
|
@ -114,7 +114,7 @@ SYMBOL: +stopped+
|
|||
] change-frame ;
|
||||
|
||||
: step-out-msg ( continuation -- continuation' )
|
||||
[ nip \ break add ] change-frame ;
|
||||
[ nip \ break suffix ] change-frame ;
|
||||
|
||||
{
|
||||
{ call [ (step-into-quot) ] }
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: ui.commands
|
|||
: command-map. ( command-map -- )
|
||||
[ command-map-row ] map
|
||||
{ "Shortcut" "Command" "Word" "Notes" }
|
||||
[ \ $strong swap ] { } map>assoc add*
|
||||
[ \ $strong swap ] { } map>assoc prefix
|
||||
$table ;
|
||||
|
||||
: $command-map ( element -- )
|
||||
|
|
|
@ -18,7 +18,7 @@ SYMBOL: grid-dim
|
|||
grid-dim get spin set-axis ;
|
||||
|
||||
: draw-grid-lines ( gaps orientation -- )
|
||||
grid get rot grid-positions grid get rect-dim add [
|
||||
grid get rot grid-positions grid get rect-dim suffix [
|
||||
grid-line-from/to gl-line
|
||||
] with each ;
|
||||
|
||||
|
|
|
@ -352,7 +352,7 @@ M: f sloppy-pick-up*
|
|||
|
||||
: sloppy-pick-up ( loc gadget -- path )
|
||||
2dup sloppy-pick-up* dup
|
||||
[ [ wet-and-sloppy sloppy-pick-up ] keep add* ]
|
||||
[ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
|
||||
[ 3drop { } ]
|
||||
if ;
|
||||
|
||||
|
|
|
@ -9,7 +9,7 @@ IN: unix.process
|
|||
! io.launcher instead.
|
||||
|
||||
: >argv ( seq -- alien )
|
||||
[ malloc-char-string ] map f add >c-void*-array ;
|
||||
[ malloc-char-string ] map f suffix >c-void*-array ;
|
||||
|
||||
: exec ( pathname argv -- int )
|
||||
[ malloc-char-string ] [ >argv ] bi* execv ;
|
||||
|
|
|
@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ;
|
|||
: rule-chars* ( rule -- string )
|
||||
dup rule-chars
|
||||
swap rule-start matcher-text
|
||||
text-hash-char [ add ] when* ;
|
||||
text-hash-char [ suffix ] when* ;
|
||||
|
||||
: add-rule ( rule ruleset -- )
|
||||
>r dup rule-chars* >upper swap
|
||||
|
|
Loading…
Reference in New Issue