parent
5aa89e6251
commit
7c7bb93c55
|
@ -228,7 +228,7 @@ M: number +second ( timestamp n -- timestamp )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# time+ 1 ( time1 time2 -- time3 )
|
||||
GENERIC#: time+ 1 ( time1 time2 -- time3 )
|
||||
|
||||
M: timestamp time+
|
||||
[ clone ] dip (time+) drop ;
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: compiler.cfg.gc-checks
|
|||
: blocks-with-gc ( cfg -- bbs )
|
||||
post-order [ insert-gc-check? ] filter ;
|
||||
|
||||
GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
|
||||
GENERIC#: gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
|
||||
|
||||
:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
|
||||
seen-allocation? [ call-index , ] when
|
||||
|
|
|
@ -71,7 +71,7 @@ M: ##horizontal-shr-vector-imm insn-available? rep>> %horizontal-shr-vector-imm-
|
|||
: [vector-op-checked] ( #dup quot -- quot )
|
||||
'[ _ ndup [ @ ] { } make dup [ insn-available? ] all? ] ;
|
||||
|
||||
GENERIC# >vector-op-cond 2 ( quot #pick #dup -- quotpair )
|
||||
GENERIC#: >vector-op-cond 2 ( quot #pick #dup -- quotpair )
|
||||
M:: callable >vector-op-cond ( quot #pick #dup -- quotpair )
|
||||
#dup quot [vector-op-checked] '[ 2drop @ ]
|
||||
#dup '[ % _ nnip ]
|
||||
|
|
|
@ -16,7 +16,7 @@ SYMBOL: components
|
|||
] each
|
||||
] simple-analysis ;
|
||||
|
||||
GENERIC# visit-insn 1 ( insn disjoint-set -- )
|
||||
GENERIC#: visit-insn 1 ( insn disjoint-set -- )
|
||||
|
||||
M: ##copy visit-insn
|
||||
[ [ dst>> ] [ src>> ] bi ] dip equate ;
|
||||
|
|
|
@ -4,8 +4,8 @@ IN: compiler.tests.redefine16
|
|||
|
||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup-word forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC#: blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC#: blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
|
||||
|
||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup-word forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
@ -40,7 +40,7 @@ M: mailbox mailbox-put
|
|||
: mailbox-peek ( mailbox -- obj )
|
||||
data>> peek-back ;
|
||||
|
||||
GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
|
||||
GENERIC#: mailbox-get-timeout 1 ( mailbox timeout -- obj )
|
||||
|
||||
M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
|
||||
|
||||
|
|
|
@ -61,7 +61,7 @@ M: indirect modifier
|
|||
|
||||
M: register modifier drop 0b11 ;
|
||||
|
||||
GENERIC# n, 1 ( value n -- )
|
||||
GENERIC#: n, 1 ( value n -- )
|
||||
|
||||
M: integer n, >le % ;
|
||||
M: byte n, [ value>> ] dip n, ;
|
||||
|
@ -214,7 +214,7 @@ M: operand POP { 0b000 f 0x8f } 1-operand ;
|
|||
: maybe-zero-extend ( reg imm -- reg' imm )
|
||||
dup zero-extendable? [ [ 32-bit-version-of ] dip ] when ;
|
||||
|
||||
GENERIC# (MOV-I) 1 ( dst src -- )
|
||||
GENERIC#: (MOV-I) 1 ( dst src -- )
|
||||
|
||||
M: register (MOV-I)
|
||||
{
|
||||
|
@ -273,7 +273,7 @@ M: operand CALL { 0b010 t 0xff } 1-operand ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
GENERIC#: JUMPcc 1 ( addr opcode -- )
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: SETcc ( dst opcode -- )
|
||||
|
|
|
@ -41,8 +41,8 @@ TUPLE: result-set sql in-params out-params handle n max ;
|
|||
GENERIC: query-results ( query -- result-set )
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set column -- obj )
|
||||
GENERIC# row-column-typed 1 ( result-set column -- sql )
|
||||
GENERIC#: row-column 1 ( result-set column -- obj )
|
||||
GENERIC#: row-column-typed 1 ( result-set column -- sql )
|
||||
GENERIC: advance-row ( result-set -- )
|
||||
GENERIC: more-rows? ( result-set -- ? )
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ C: <goodbye> goodbye
|
|||
|
||||
GENERIC: foo ( x -- y )
|
||||
GENERIC: bar ( a -- b )
|
||||
GENERIC# whoa 1 ( s t -- w )
|
||||
GENERIC#: whoa 1 ( s t -- w )
|
||||
PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
|
||||
|
||||
: hello-test ( hello/goodbye -- array )
|
||||
|
|
|
@ -62,7 +62,7 @@ PREDICATE: consult-method < method
|
|||
M: consult-method reset-word
|
||||
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
|
||||
|
||||
GENERIC# (consult-method-quot) 2 ( consultation quot word -- object )
|
||||
GENERIC#: (consult-method-quot) 2 ( consultation quot word -- object )
|
||||
|
||||
M: consultation (consult-method-quot)
|
||||
'[ _ call _ execute ] nip ;
|
||||
|
|
|
@ -22,7 +22,7 @@ PRIVATE>
|
|||
|
||||
! Image Decode
|
||||
|
||||
GENERIC# load-image* 1 ( obj class -- image )
|
||||
GENERIC#: load-image* 1 ( obj class -- image )
|
||||
|
||||
GENERIC: stream>image* ( stream class -- image )
|
||||
|
||||
|
|
|
@ -111,7 +111,7 @@ M: unix stat>type ( stat -- type )
|
|||
[ dup stat-mode ] 2dip
|
||||
[ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ;
|
||||
|
||||
GENERIC# file-mode? 1 ( obj mask -- ? )
|
||||
GENERIC#: file-mode? 1 ( obj mask -- ? )
|
||||
|
||||
M: integer file-mode? mask? ;
|
||||
M: string file-mode? [ stat-mode ] dip mask? ;
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: io.sockets
|
|||
{ [ os unix? ] [ "unix.ffi" ] }
|
||||
} cond use-vocab >>
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
GENERIC#: with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
! Addressing
|
||||
<PRIVATE
|
||||
|
|
|
@ -20,7 +20,7 @@ INSTANCE: limited-stream input-stream
|
|||
[ drop file-info size>> ] 2bi
|
||||
<limited-stream> ;
|
||||
|
||||
GENERIC# limit-stream 1 ( stream limit -- stream' )
|
||||
GENERIC#: limit-stream 1 ( stream limit -- stream' )
|
||||
|
||||
M: decoder limit-stream ( stream limit -- stream' )
|
||||
'[ stream>> _ limit-stream ] [ code>> ] [ cr>> ] tri
|
||||
|
|
|
@ -22,7 +22,7 @@ SYMBOL: json-escape-unicode?
|
|||
f json-escape-unicode? set-global
|
||||
|
||||
! Writes the object out to a stream in JSON format
|
||||
GENERIC# stream-json-print 1 ( obj stream -- )
|
||||
GENERIC#: stream-json-print 1 ( obj stream -- )
|
||||
|
||||
: json-print ( obj -- )
|
||||
output-stream get stream-json-print ;
|
||||
|
|
|
@ -8,7 +8,7 @@ vocabs.parser ;
|
|||
IN: listener
|
||||
|
||||
GENERIC: stream-read-quot ( stream -- quot/f )
|
||||
GENERIC# prompt. 1 ( stream prompt -- )
|
||||
GENERIC#: prompt. 1 ( stream prompt -- )
|
||||
|
||||
: prompt ( -- str )
|
||||
manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
|
||||
|
|
|
@ -103,7 +103,7 @@ write-test-2 "q" set
|
|||
|
||||
GENERIC: lambda-generic ( a b -- c )
|
||||
|
||||
GENERIC# lambda-generic-1 1 ( a b -- c )
|
||||
GENERIC#: lambda-generic-1 1 ( a b -- c )
|
||||
|
||||
M:: integer lambda-generic-1 ( a b -- c ) a b * ;
|
||||
|
||||
|
@ -112,7 +112,7 @@ M:: string lambda-generic-1 ( a b -- c )
|
|||
|
||||
M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
|
||||
|
||||
GENERIC# lambda-generic-2 1 ( a b -- c )
|
||||
GENERIC#: lambda-generic-2 1 ( a b -- c )
|
||||
|
||||
M:: integer lambda-generic-2 ( a b -- c )
|
||||
a CHAR: x <string> b lambda-generic ;
|
||||
|
|
|
@ -67,16 +67,16 @@ HOOK: (fp-env-registers) cpu ( -- registers )
|
|||
GENERIC: (set-fp-env-register) ( fp-env -- )
|
||||
|
||||
GENERIC: (get-exception-flags) ( fp-env -- exceptions )
|
||||
GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
|
||||
GENERIC#: (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
|
||||
|
||||
GENERIC: (get-fp-traps) ( fp-env -- exceptions )
|
||||
GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
|
||||
GENERIC#: (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
|
||||
|
||||
GENERIC: (get-rounding-mode) ( fp-env -- mode )
|
||||
GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
|
||||
GENERIC#: (set-rounding-mode) 1 ( fp-env mode -- fp-env )
|
||||
|
||||
GENERIC: (get-denormal-mode) ( fp-env -- mode )
|
||||
GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
|
||||
GENERIC#: (set-denormal-mode) 1 ( fp-env mode -- fp-env )
|
||||
|
||||
: change-fp-env-registers ( quot -- )
|
||||
(fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
|
||||
|
|
|
@ -32,7 +32,7 @@ M: real sqrt
|
|||
: (^n) ( z w -- z^w )
|
||||
dup fixnum? [ (^fixnum) ] [ (^bignum) ] if ; inline
|
||||
|
||||
GENERIC# ^n 1 ( z w -- z^w ) foldable
|
||||
GENERIC#: ^n 1 ( z w -- z^w ) foldable
|
||||
|
||||
M: fixnum ^n (^n) ;
|
||||
|
||||
|
@ -168,7 +168,7 @@ M: integer frexp
|
|||
|
||||
DEFER: copysign
|
||||
|
||||
GENERIC# ldexp 1 ( x exp -- y )
|
||||
GENERIC#: ldexp 1 ( x exp -- y )
|
||||
|
||||
M: float ldexp
|
||||
over fp-special? [ over zero? ] unless* [ drop ] [
|
||||
|
|
|
@ -9,25 +9,25 @@ IN: math.vectors
|
|||
GENERIC: vneg ( v -- w )
|
||||
M: object vneg [ neg ] map ; inline
|
||||
|
||||
GENERIC# v+n 1 ( v n -- w )
|
||||
GENERIC#: v+n 1 ( v n -- w )
|
||||
M: object v+n [ + ] curry map ; inline
|
||||
|
||||
GENERIC: n+v ( n v -- w )
|
||||
M: object n+v [ + ] with map ; inline
|
||||
|
||||
GENERIC# v-n 1 ( v n -- w )
|
||||
GENERIC#: v-n 1 ( v n -- w )
|
||||
M: object v-n [ - ] curry map ; inline
|
||||
|
||||
GENERIC: n-v ( n v -- w )
|
||||
M: object n-v [ - ] with map ; inline
|
||||
|
||||
GENERIC# v*n 1 ( v n -- w )
|
||||
GENERIC#: v*n 1 ( v n -- w )
|
||||
M: object v*n [ * ] curry map ; inline
|
||||
|
||||
GENERIC: n*v ( n v -- w )
|
||||
M: object n*v [ * ] with map ; inline
|
||||
|
||||
GENERIC# v/n 1 ( v n -- w )
|
||||
GENERIC#: v/n 1 ( v n -- w )
|
||||
M: object v/n [ / ] curry map ; inline
|
||||
|
||||
GENERIC: n/v ( n v -- w )
|
||||
|
@ -116,31 +116,31 @@ M: object vbitxor [ bitxor ] 2map ; inline
|
|||
GENERIC: vbitnot ( v -- w )
|
||||
M: object vbitnot [ bitnot ] map ; inline
|
||||
|
||||
GENERIC# vbroadcast 1 ( u n -- v )
|
||||
GENERIC#: vbroadcast 1 ( u n -- v )
|
||||
M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; inline
|
||||
|
||||
GENERIC# vshuffle-elements 1 ( v perm -- w )
|
||||
GENERIC#: vshuffle-elements 1 ( v perm -- w )
|
||||
M: object vshuffle-elements
|
||||
over length 0 pad-tail
|
||||
swap [ '[ _ nth ] ] keep map-as ; inline
|
||||
|
||||
GENERIC# vshuffle2-elements 1 ( u v perm -- w )
|
||||
GENERIC#: vshuffle2-elements 1 ( u v perm -- w )
|
||||
M: object vshuffle2-elements
|
||||
[ append ] dip vshuffle-elements ; inline
|
||||
|
||||
GENERIC# vshuffle-bytes 1 ( v perm -- w )
|
||||
GENERIC#: vshuffle-bytes 1 ( v perm -- w )
|
||||
|
||||
GENERIC: vshuffle ( v perm -- w )
|
||||
M: array vshuffle ( v perm -- w )
|
||||
vshuffle-elements ; inline
|
||||
|
||||
GENERIC# vlshift 1 ( v n -- w )
|
||||
GENERIC#: vlshift 1 ( v n -- w )
|
||||
M: object vlshift '[ _ shift ] map ; inline
|
||||
GENERIC# vrshift 1 ( v n -- w )
|
||||
GENERIC#: vrshift 1 ( v n -- w )
|
||||
M: object vrshift neg '[ _ shift ] map ; inline
|
||||
|
||||
GENERIC# hlshift 1 ( v n -- w )
|
||||
GENERIC# hrshift 1 ( v n -- w )
|
||||
GENERIC#: hlshift 1 ( v n -- w )
|
||||
GENERIC#: hrshift 1 ( v n -- w )
|
||||
|
||||
GENERIC: (vmerge-head) ( u v -- h )
|
||||
M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; inline
|
||||
|
|
|
@ -14,7 +14,7 @@ SYMBOL: system-random-generator
|
|||
SYMBOL: secure-random-generator
|
||||
SYMBOL: random-generator
|
||||
|
||||
GENERIC# seed-random 1 ( obj seed -- obj )
|
||||
GENERIC#: seed-random 1 ( obj seed -- obj )
|
||||
GENERIC: random-32* ( obj -- n )
|
||||
GENERIC: random-bytes* ( n obj -- byte-array )
|
||||
|
||||
|
@ -76,7 +76,7 @@ PRIVATE>
|
|||
[ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri*
|
||||
] while drop [ m * ] [ neg shift ] bi* ; inline
|
||||
|
||||
GENERIC# (random-integer) 1 ( m obj -- n )
|
||||
GENERIC#: (random-integer) 1 ( m obj -- n )
|
||||
M: fixnum (random-integer) ( m obj -- n ) random-integer-loop ;
|
||||
M: bignum (random-integer) ( m obj -- n ) random-integer-loop ;
|
||||
|
||||
|
|
|
@ -274,7 +274,7 @@ M: primitive-class class-member?
|
|||
TUPLE: condition question yes no ;
|
||||
C: <condition> condition
|
||||
|
||||
GENERIC# answer 2 ( class from to -- new-class )
|
||||
GENERIC#: answer 2 ( class from to -- new-class )
|
||||
|
||||
M:: object answer ( class from to -- new-class )
|
||||
class from = to class ? ;
|
||||
|
@ -291,7 +291,7 @@ M: or-class answer
|
|||
M: not-class answer
|
||||
[ class>> ] 2dip answer <not-class> ;
|
||||
|
||||
GENERIC# substitute 1 ( class from to -- new-class )
|
||||
GENERIC#: substitute 1 ( class from to -- new-class )
|
||||
M: object substitute answer ;
|
||||
M: not-class substitute [ <not-class> ] bi@ answer ;
|
||||
|
||||
|
|
|
@ -42,7 +42,7 @@ PREDICATE: annotated < word "unannotated-def" word-prop >boolean ;
|
|||
[ check-annotate-twice ] dip
|
||||
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip ;
|
||||
|
||||
GENERIC# (annotate) 1 ( word quot -- )
|
||||
GENERIC#: (annotate) 1 ( word quot -- )
|
||||
|
||||
M: generic (annotate)
|
||||
'[ _ (annotate) ] annotate-generic ;
|
||||
|
@ -51,7 +51,7 @@ M: word (annotate)
|
|||
prepare-annotate
|
||||
call( old -- new ) define ;
|
||||
|
||||
GENERIC# (deep-annotate) 1 ( word quot -- )
|
||||
GENERIC#: (deep-annotate) 1 ( word quot -- )
|
||||
|
||||
M: generic (deep-annotate)
|
||||
'[ _ (deep-annotate) ] annotate-generic ;
|
||||
|
|
|
@ -15,7 +15,7 @@ GENERIC: uses ( defspec -- seq )
|
|||
|
||||
SYMBOL: visited
|
||||
|
||||
GENERIC# quot-uses 1 ( obj set -- )
|
||||
GENERIC#: quot-uses 1 ( obj set -- )
|
||||
|
||||
M: object quot-uses 2drop ;
|
||||
|
||||
|
|
|
@ -129,7 +129,7 @@ M: world request-focus-on ( child gadget -- )
|
|||
[ T{ rgba f 0.0 0.0 0.0 0.0 } ]
|
||||
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
|
||||
|
||||
GENERIC# apply-world-attributes 1 ( world attributes -- world )
|
||||
GENERIC#: apply-world-attributes 1 ( world attributes -- world )
|
||||
|
||||
M: world apply-world-attributes
|
||||
{
|
||||
|
|
|
@ -64,4 +64,4 @@ M: pixel-format dispose*
|
|||
|
||||
GENERIC: world-pixel-format-attributes ( world -- attributes )
|
||||
|
||||
GENERIC# check-world-pixel-format 1 ( world pixel-format -- )
|
||||
GENERIC#: check-world-pixel-format 1 ( world pixel-format -- )
|
||||
|
|
|
@ -126,7 +126,7 @@ M: object completion-string present ;
|
|||
|
||||
M: method completion-string method-completion-string ;
|
||||
|
||||
GENERIC# accept-completion-hook 1 ( item popup -- )
|
||||
GENERIC#: accept-completion-hook 1 ( item popup -- )
|
||||
|
||||
: insert-completion ( item popup -- )
|
||||
[ completion-string ] [ completion-loc/doc/elt ] bi* set-elt-string ;
|
||||
|
|
|
@ -89,7 +89,7 @@ M: node gadget-text*
|
|||
: gadget-at-path ( parent path -- gadget )
|
||||
[ swap nth-gadget ] each ;
|
||||
|
||||
GENERIC# leaves* 1 ( tree set -- )
|
||||
GENERIC#: leaves* 1 ( tree set -- )
|
||||
|
||||
M: node leaves* [ children>> ] dip leaves* ;
|
||||
|
||||
|
|
|
@ -278,7 +278,7 @@ TUPLE: proc-uptime up idle ;
|
|||
|
||||
! /proc/pid/*
|
||||
|
||||
GENERIC# proc-pid-path 1 ( object string -- path )
|
||||
GENERIC#: proc-pid-path 1 ( object string -- path )
|
||||
|
||||
M: integer proc-pid-path ( pid string -- path )
|
||||
[ "/proc/" ] 2dip
|
||||
|
|
|
@ -7,7 +7,7 @@ namespaces sequences sequences.private strings strings.private
|
|||
system system.private ;
|
||||
IN: alien.strings
|
||||
|
||||
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
|
||||
GENERIC#: alien>string 1 ( c-ptr encoding -- string/f )
|
||||
|
||||
M: c-ptr alien>string
|
||||
[ <memory-stream> ] [ <decoder> ] bi*
|
||||
|
@ -24,7 +24,7 @@ ERROR: invalid-c-string string ;
|
|||
: check-string ( string -- )
|
||||
0 over member-eq? [ invalid-c-string ] [ drop ] if ;
|
||||
|
||||
GENERIC# string>alien 1 ( string encoding -- byte-array )
|
||||
GENERIC#: string>alien 1 ( string encoding -- byte-array )
|
||||
|
||||
M: c-ptr string>alien drop ;
|
||||
|
||||
|
|
|
@ -20,7 +20,7 @@ IN: bootstrap.syntax
|
|||
"DEFER:"
|
||||
"ERROR:"
|
||||
"FORGET:"
|
||||
"GENERIC#"
|
||||
"GENERIC#:"
|
||||
"GENERIC:"
|
||||
"HOOK:"
|
||||
"H{"
|
||||
|
|
|
@ -35,7 +35,7 @@ M: checksum-state clone
|
|||
new BV{ } clone >>bytes ;
|
||||
|
||||
GENERIC: initialize-checksum-state ( checksum -- checksum-state )
|
||||
GENERIC# add-checksum-bytes 1 ( checksum-state data -- checksum-state )
|
||||
GENERIC#: add-checksum-bytes 1 ( checksum-state data -- checksum-state )
|
||||
GENERIC: get-checksum ( checksum-state -- value )
|
||||
|
||||
: with-checksum-state ( ..a checksum quot: ( ..a checksum-state -- ..b ) -- ..b )
|
||||
|
|
|
@ -91,7 +91,7 @@ ERROR: bad-slot-name class slot ;
|
|||
: parse-slot-values ( class slots -- values )
|
||||
[ (parse-slot-values) ] { } make ;
|
||||
|
||||
GENERIC# boa>object 1 ( class slots -- tuple )
|
||||
GENERIC#: boa>object 1 ( class slots -- tuple )
|
||||
|
||||
M: tuple-class boa>object
|
||||
swap slots>tuple ;
|
||||
|
|
|
@ -139,8 +139,8 @@ M: integer forget-robustness-generic ;
|
|||
] with-compilation-unit
|
||||
|
||||
! rapido found this one
|
||||
GENERIC# m1 0 ( s n -- n )
|
||||
GENERIC# m2 1 ( s n -- v )
|
||||
GENERIC#: m1 0 ( s n -- n )
|
||||
GENERIC#: m2 1 ( s n -- v )
|
||||
|
||||
TUPLE: t1 ;
|
||||
|
||||
|
|
|
@ -277,7 +277,7 @@ M: tuple-class update-class
|
|||
dup final-class? [ bad-superclass ] when
|
||||
dup class? [ bad-superclass ] unless drop ;
|
||||
|
||||
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
|
||||
GENERIC#: (define-tuple-class) 2 ( class superclass slots -- )
|
||||
|
||||
: thrower-effect ( slots -- effect )
|
||||
[ name>> ] map { "*" } <effect> ;
|
||||
|
|
|
@ -61,7 +61,7 @@ ARTICLE: "method-combination" "Custom method combination"
|
|||
"A table of built-in method combination defining words, and the method combinations themselves:"
|
||||
{ $table
|
||||
{ { $link POSTPONE: GENERIC: } { $link standard-combination } }
|
||||
{ { $link POSTPONE: GENERIC# } { $link standard-combination } }
|
||||
{ { $link POSTPONE: GENERIC#: } { $link standard-combination } }
|
||||
{ { $link POSTPONE: HOOK: } { $link hook-combination } }
|
||||
{ { $link POSTPONE: MATH: } { $link math-combination } }
|
||||
}
|
||||
|
@ -93,7 +93,7 @@ $nl
|
|||
"Generic words which dispatch on the object at the top of the stack:"
|
||||
{ $subsections POSTPONE: GENERIC: }
|
||||
"A method combination which dispatches on a specified stack position:"
|
||||
{ $subsections POSTPONE: GENERIC# }
|
||||
{ $subsections POSTPONE: GENERIC#: }
|
||||
"A method combination which dispatches on the value of a variable at the time the generic word is called:"
|
||||
{ $subsections POSTPONE: HOOK: }
|
||||
"A method combination which dispatches on a pair of stack values, which must be numbers, and upgrades both to the same type of number:"
|
||||
|
@ -114,7 +114,7 @@ ABOUT: "generic"
|
|||
HELP: generic
|
||||
{ $class-description "The class of generic words, documented in " { $link "generic" } "." } ;
|
||||
|
||||
{ generic define-generic define-simple-generic POSTPONE: GENERIC: POSTPONE: GENERIC# POSTPONE: MATH: POSTPONE: HOOK: } related-words
|
||||
{ generic define-generic define-simple-generic POSTPONE: GENERIC: POSTPONE: GENERIC#: POSTPONE: MATH: POSTPONE: HOOK: } related-words
|
||||
|
||||
HELP: make-generic
|
||||
{ $values { "word" generic } }
|
||||
|
|
|
@ -186,7 +186,7 @@ M: method forget*
|
|||
[ call-next-method ] bi
|
||||
] if ;
|
||||
|
||||
GENERIC# check-combination-effect 1 ( combination effect -- )
|
||||
GENERIC#: check-combination-effect 1 ( combination effect -- )
|
||||
|
||||
M: object check-combination-effect 2drop ;
|
||||
|
||||
|
|
|
@ -10,7 +10,7 @@ HELP: standard-combination
|
|||
{ $examples
|
||||
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
|
||||
{ $code
|
||||
"GENERIC# build-string 1 ( elt str -- )"
|
||||
"GENERIC#: build-string 1 ( elt str -- )"
|
||||
"M: string build-string swap push-all ;"
|
||||
"M: integer build-string push ;"
|
||||
}
|
||||
|
|
|
@ -194,7 +194,7 @@ M: byte-array small-lo-tag drop "byte-array" ;
|
|||
] must-fail
|
||||
{ } [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
|
||||
|
||||
GENERIC# complex-combination 1 ( a b -- c )
|
||||
GENERIC#: complex-combination 1 ( a b -- c )
|
||||
M: string complex-combination drop ;
|
||||
M: object complex-combination nip ;
|
||||
|
||||
|
@ -368,13 +368,13 @@ M: c funky* "c" , call-next-method ;
|
|||
[ "IN: generic.standard.tests GENERIC: broken-generic ( -- )" eval( -- ) ]
|
||||
[ error>> bad-dispatch-position? ]
|
||||
must-fail-with
|
||||
[ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
|
||||
[ "IN: generic.standard.tests GENERIC#: broken-generic# -1 ( a -- b )" eval( -- ) ]
|
||||
[ error>> bad-dispatch-position? ]
|
||||
must-fail-with
|
||||
[ "IN: generic.standard.tests GENERIC# broken-generic# 1 ( a -- b )" eval( -- ) ]
|
||||
[ "IN: generic.standard.tests GENERIC#: broken-generic# 1 ( a -- b )" eval( -- ) ]
|
||||
[ error>> bad-dispatch-position? ]
|
||||
must-fail-with
|
||||
[ "IN: generic.standard.tests GENERIC# broken-generic# 2/3 ( a b c -- )" eval( -- ) ]
|
||||
[ "IN: generic.standard.tests GENERIC#: broken-generic# 2/3 ( a b c -- )" eval( -- ) ]
|
||||
[ error>> bad-dispatch-position? ]
|
||||
must-fail-with
|
||||
|
||||
|
|
|
@ -63,6 +63,6 @@ M: standard-combination inline-cache-quots
|
|||
M: standard-combination mega-cache-quot
|
||||
combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
|
||||
|
||||
M: standard-generic definer drop \ GENERIC# f ;
|
||||
M: standard-generic definer drop \ GENERIC#: f ;
|
||||
|
||||
M: simple-generic definer drop \ GENERIC: f ;
|
||||
|
|
|
@ -205,7 +205,7 @@ INSTANCE: encoder plain-writer
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# re-encode 1 ( stream encoding -- newstream )
|
||||
GENERIC#: re-encode 1 ( stream encoding -- newstream )
|
||||
|
||||
M: object re-encode <encoder> ;
|
||||
|
||||
|
@ -218,7 +218,7 @@ M: encoder re-encode [ stream>> ] dip re-encode ;
|
|||
[ [ output-stream get ] dip re-encode ] dip
|
||||
with-output-stream* ; inline
|
||||
|
||||
GENERIC# re-decode 1 ( stream encoding -- newstream )
|
||||
GENERIC#: re-decode 1 ( stream encoding -- newstream )
|
||||
|
||||
M: object re-decode <decoder> ;
|
||||
|
||||
|
|
|
@ -114,7 +114,7 @@ M: utf16le encode-char ( char stream encoding -- )
|
|||
: ascii-string>utf16be ( string stream -- )
|
||||
[ 1 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
|
||||
|
||||
GENERIC# encode-string-utf16le 1 ( string stream -- )
|
||||
GENERIC#: encode-string-utf16le 1 ( string stream -- )
|
||||
|
||||
M: object encode-string-utf16le
|
||||
[ char>utf16le ] curry each ; inline
|
||||
|
@ -126,7 +126,7 @@ M: string encode-string-utf16le
|
|||
|
||||
M: utf16le encode-string drop encode-string-utf16le ;
|
||||
|
||||
GENERIC# encode-string-utf16be 1 ( string stream -- )
|
||||
GENERIC#: encode-string-utf16be 1 ( string stream -- )
|
||||
|
||||
M: object encode-string-utf16be
|
||||
[ char>utf16be ] curry each ; inline
|
||||
|
|
|
@ -84,7 +84,7 @@ M: utf8 decode-until (decode-until) ;
|
|||
M: utf8 encode-char
|
||||
drop char>utf8 ;
|
||||
|
||||
GENERIC# encode-string-utf8 1 ( string stream -- )
|
||||
GENERIC#: encode-string-utf8 1 ( string stream -- )
|
||||
|
||||
M: object encode-string-utf8
|
||||
[ char>utf8 ] curry each ; inline
|
||||
|
|
|
@ -119,9 +119,9 @@ MATH: /mod ( x y -- z w ) foldable
|
|||
MATH: bitand ( x y -- z ) foldable
|
||||
MATH: bitor ( x y -- z ) foldable
|
||||
MATH: bitxor ( x y -- z ) foldable
|
||||
GENERIC# shift 1 ( x n -- y ) foldable
|
||||
GENERIC#: shift 1 ( x n -- y ) foldable
|
||||
GENERIC: bitnot ( x -- y ) foldable
|
||||
GENERIC# bit? 1 ( x n -- ? ) foldable
|
||||
GENERIC#: bit? 1 ( x n -- ? ) foldable
|
||||
|
||||
GENERIC: abs ( x -- y ) foldable
|
||||
|
||||
|
|
|
@ -464,7 +464,7 @@ M: fixnum (positive>dec)
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# >base 1 ( n radix -- str )
|
||||
GENERIC#: >base 1 ( n radix -- str )
|
||||
|
||||
: number>string ( n -- str ) 10 >base ; inline
|
||||
|
||||
|
|
|
@ -438,7 +438,7 @@ DEFER: foo
|
|||
{
|
||||
"IN: parser.tests"
|
||||
"USING: math arrays kernel ;"
|
||||
"GENERIC# change-combination 1 ( obj a -- b )"
|
||||
"GENERIC#: change-combination 1 ( obj a -- b )"
|
||||
"M: integer change-combination 2drop 1 ;"
|
||||
"M: array change-combination 2drop 2 ;"
|
||||
} "\n" join <string-reader> "change-combination-test" parse-stream drop
|
||||
|
|
|
@ -51,7 +51,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
|
|||
|
||||
ERROR: bounds-error index seq ;
|
||||
|
||||
GENERIC# bounds-check? 1 ( n seq -- ? )
|
||||
GENERIC#: bounds-check? 1 ( n seq -- ? )
|
||||
|
||||
M: integer bounds-check? ( n seq -- ? )
|
||||
dupd length < [ 0 >= ] [ drop f ] if ; inline
|
||||
|
|
|
@ -33,7 +33,7 @@ PREDICATE: writer-method < method "writing" word-prop >boolean ;
|
|||
[ 2drop make-inline ]
|
||||
3tri ;
|
||||
|
||||
GENERIC# reader-quot 1 ( class slot-spec -- quot )
|
||||
GENERIC#: reader-quot 1 ( class slot-spec -- quot )
|
||||
|
||||
M: object reader-quot
|
||||
nip [
|
||||
|
@ -87,7 +87,7 @@ M: object instance-check-quot
|
|||
\ unless ,
|
||||
] [ ] make ;
|
||||
|
||||
GENERIC# writer-quot 1 ( class slot-spec -- quot )
|
||||
GENERIC#: writer-quot 1 ( class slot-spec -- quot )
|
||||
|
||||
M: object writer-quot
|
||||
nip
|
||||
|
|
|
@ -669,14 +669,14 @@ HELP: GENERIC:
|
|||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
|
||||
|
||||
HELP: GENERIC#
|
||||
{ $syntax "GENERIC# word n ( stack -- effect )" }
|
||||
HELP: GENERIC#:
|
||||
{ $syntax "GENERIC#: word n ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
|
||||
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
|
||||
{ $notes
|
||||
"The following two definitions are equivalent:"
|
||||
{ $code "GENERIC: foo ( obj -- )" }
|
||||
{ $code "GENERIC# foo 0 ( obj -- )" }
|
||||
{ $code "GENERIC#: foo 0 ( obj -- )" }
|
||||
} ;
|
||||
|
||||
HELP: MATH:
|
||||
|
|
|
@ -164,7 +164,7 @@ IN: bootstrap.syntax
|
|||
[ simple-combination ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
"GENERIC#" [
|
||||
"GENERIC#:" [
|
||||
[ scan-number <standard-combination> ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
|
|
|
@ -84,7 +84,7 @@ SYMBOL: cond-code
|
|||
: insn ( bitspec -- ) bitfield (insn) ; inline
|
||||
|
||||
! Branching instructions
|
||||
GENERIC# (B) 1 ( target l -- )
|
||||
GENERIC#: (B) 1 ( target l -- )
|
||||
|
||||
M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
|
||||
|
||||
|
@ -109,7 +109,7 @@ PRIVATE>
|
|||
: sinsn ( bitspec -- )
|
||||
bitfield S> [ 20 2^ bitor ] when (insn) ; inline
|
||||
|
||||
GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
|
||||
GENERIC#: shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
|
||||
|
||||
M: integer shift-imm/reg ( shift-imm Rm shift -- n )
|
||||
{ { 0 4 } 5 { register 0 } 7 } bitfield ;
|
||||
|
@ -294,7 +294,7 @@ SYMBOL: have-BLX?
|
|||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC# (BX) 1 ( Rm l -- )
|
||||
GENERIC#: (BX) 1 ( Rm l -- )
|
||||
|
||||
M: register-class (BX) ( Rm l -- )
|
||||
{
|
||||
|
|
|
@ -40,8 +40,8 @@ GENERIC: dec-cursor ( cursor -- cursor' )
|
|||
MIXIN: random-access-cursor
|
||||
INSTANCE: random-access-cursor bidirectional-cursor
|
||||
|
||||
GENERIC# cursor+ 1 ( cursor n -- cursor' )
|
||||
GENERIC# cursor- 1 ( cursor n -- cursor' )
|
||||
GENERIC#: cursor+ 1 ( cursor n -- cursor' )
|
||||
GENERIC#: cursor- 1 ( cursor n -- cursor' )
|
||||
GENERIC: cursor-distance ( cursor cursor -- n )
|
||||
GENERIC: cursor< ( cursor cursor -- ? )
|
||||
GENERIC: cursor> ( cursor cursor -- ? )
|
||||
|
@ -391,7 +391,7 @@ M: pusher-cursor set-cursor-value growable>> push ; inline
|
|||
: new-growable-cursor ( begin end exemplar -- cursor result )
|
||||
[ swap cursor-distance-hint ] dip new-resizable [ <pusher-cursor> ] keep ; inline
|
||||
|
||||
GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result )
|
||||
GENERIC#: new-sequence-cursor 1 ( begin end exemplar -- cursor result )
|
||||
|
||||
M: random-access-cursor new-sequence-cursor
|
||||
[ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline
|
||||
|
|
|
@ -38,7 +38,7 @@ TUPLE: game-loop-error-state error game-loop ;
|
|||
[ draw-timer>> iteration-start-nanos>> nano-count swap - ]
|
||||
[ tick-interval-nanos>> ] bi /f 1.0 min ;
|
||||
|
||||
GENERIC# record-benchmarking 1 ( loop quot -- )
|
||||
GENERIC#: record-benchmarking 1 ( loop quot -- )
|
||||
|
||||
M: object record-benchmarking
|
||||
call( loop -- ) ;
|
||||
|
|
|
@ -26,7 +26,7 @@ types [ H{ } clone ] initialize
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# load-models* 2 ( obj encoding class -- models )
|
||||
GENERIC#: load-models* 2 ( obj encoding class -- models )
|
||||
|
||||
GENERIC: stream>models ( stream class -- models )
|
||||
|
||||
|
|
|
@ -23,12 +23,12 @@ INSTANCE: proc sequence
|
|||
|
||||
: wrap ( n seq -- n seq ) [ length rem ] keep ; inline
|
||||
|
||||
GENERIC# (gml-get) 1 ( collection key -- elt )
|
||||
GENERIC#: (gml-get) 1 ( collection key -- elt )
|
||||
|
||||
M: sequence (gml-get) swap wrap nth ;
|
||||
M: hashtable (gml-get) of ;
|
||||
|
||||
GENERIC# (gml-put) 2 ( collection key elt -- )
|
||||
GENERIC#: (gml-put) 2 ( collection key elt -- )
|
||||
|
||||
M:: sequence (gml-put) ( collection key elt -- )
|
||||
elt key collection wrap set-nth ;
|
||||
|
|
|
@ -141,7 +141,7 @@ GENERIC: framebuffer-handle ( framebuffer -- handle )
|
|||
M: system-framebuffer framebuffer-handle drop 0 ;
|
||||
M: framebuffer framebuffer-handle handle>> ;
|
||||
|
||||
GENERIC# allocate-framebuffer-attachment 1 ( framebuffer-attachment dim -- )
|
||||
GENERIC#: allocate-framebuffer-attachment 1 ( framebuffer-attachment dim -- )
|
||||
|
||||
M: texture-attachment allocate-framebuffer-attachment
|
||||
[ [ texture>> ] [ level>> ] bi ] dip f allocate-texture ;
|
||||
|
|
|
@ -139,7 +139,7 @@ ERROR: invalid-uniform-type uniform ;
|
|||
|
||||
GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
|
||||
|
||||
GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
|
||||
GENERIC#: render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
|
||||
|
||||
GENERIC: gl-array-element-type ( array -- type )
|
||||
M: uchar-array gl-array-element-type drop GL_UNSIGNED_BYTE ; inline
|
||||
|
@ -264,14 +264,14 @@ GENERIC: >uniform-int-array ( sequence -- c-array )
|
|||
GENERIC: >uniform-uint-array ( sequence -- c-array )
|
||||
GENERIC: >uniform-float-array ( sequence -- c-array )
|
||||
|
||||
GENERIC# >uniform-bvec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC# >uniform-ivec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC# >uniform-uvec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC# >uniform-vec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC#: >uniform-bvec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC#: >uniform-ivec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC#: >uniform-uvec-array 1 ( sequence dim -- c-array )
|
||||
GENERIC#: >uniform-vec-array 1 ( sequence dim -- c-array )
|
||||
|
||||
GENERIC# >uniform-matrix 2 ( sequence cols rows -- c-array )
|
||||
GENERIC#: >uniform-matrix 2 ( sequence cols rows -- c-array )
|
||||
|
||||
GENERIC# >uniform-matrix-array 2 ( sequence cols rows -- c-array )
|
||||
GENERIC#: >uniform-matrix-array 2 ( sequence cols rows -- c-array )
|
||||
|
||||
GENERIC: bind-uniform-bvec2 ( index sequence -- )
|
||||
GENERIC: bind-uniform-bvec3 ( index sequence -- )
|
||||
|
|
|
@ -203,7 +203,7 @@ M: cube-map-face texture-data-gl-target
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# allocate-texture 3 ( tdt level dim data -- )
|
||||
GENERIC#: allocate-texture 3 ( tdt level dim data -- )
|
||||
|
||||
M: texture-1d-data-target allocate-texture ( tdt level dim data -- )
|
||||
[ ] [ glTexImage1D ] (allocate-texture) ;
|
||||
|
@ -214,7 +214,7 @@ M: texture-2d-data-target allocate-texture ( tdt level dim data -- )
|
|||
M: texture-3d-data-target allocate-texture ( tdt level dim data -- )
|
||||
[ first3 ] [ glTexImage3D ] (allocate-texture) ;
|
||||
|
||||
GENERIC# allocate-compressed-texture 3 ( tdt level dim compressed-data -- )
|
||||
GENERIC#: allocate-compressed-texture 3 ( tdt level dim compressed-data -- )
|
||||
|
||||
M: texture-1d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
|
||||
[ ] [ glCompressedTexImage1D ] (allocate-compressed-texture) ;
|
||||
|
@ -225,7 +225,7 @@ M: texture-2d-data-target allocate-compressed-texture ( tdt level dim compressed
|
|||
M: texture-3d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
|
||||
[ first3 ] [ glCompressedTexImage3D ] (allocate-compressed-texture) ;
|
||||
|
||||
GENERIC# update-texture 4 ( tdt level loc dim data -- )
|
||||
GENERIC#: update-texture 4 ( tdt level loc dim data -- )
|
||||
|
||||
M: texture-1d-data-target update-texture ( tdt level loc dim data -- )
|
||||
[ ] [ glTexSubImage1D ] (update-texture) ;
|
||||
|
@ -236,7 +236,7 @@ M: texture-2d-data-target update-texture ( tdt level loc dim data -- )
|
|||
M: texture-3d-data-target update-texture ( tdt level loc dim data -- )
|
||||
[ first3 ] [ glTexSubImage3D ] (update-texture) ;
|
||||
|
||||
GENERIC# update-compressed-texture 4 ( tdt level loc dim compressed-data -- )
|
||||
GENERIC#: update-compressed-texture 4 ( tdt level loc dim compressed-data -- )
|
||||
|
||||
M: texture-1d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
|
||||
[ ] [ glCompressedTexSubImage1D ] (update-compressed-texture) ;
|
||||
|
@ -251,7 +251,7 @@ M: texture-3d-data-target update-compressed-texture ( tdt level loc dim compress
|
|||
{ [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
|
||||
<texture-data> ; inline
|
||||
|
||||
GENERIC# texture-dim 1 ( tdt level -- dim )
|
||||
GENERIC#: texture-dim 1 ( tdt level -- dim )
|
||||
|
||||
M:: texture-1d-data-target texture-dim ( tdt level -- dim )
|
||||
tdt bind-tdt :> texture
|
||||
|
|
|
@ -11,7 +11,7 @@ IN: graphviz.notation
|
|||
|
||||
<PRIVATE
|
||||
|
||||
! GENERIC# =attr 1 ( graphviz-obj val -- graphviz-obj' )
|
||||
! GENERIC#: =attr 1 ( graphviz-obj val -- graphviz-obj' )
|
||||
! M: edge/node =attr
|
||||
! present over attributes>> attr<< ;
|
||||
! M: sub/graph =attr
|
||||
|
|
|
@ -6,9 +6,9 @@ shuffle ;
|
|||
IN: monads
|
||||
|
||||
! Functors
|
||||
GENERIC# fmap 1 ( functor quot -- functor' )
|
||||
GENERIC# <$ 1 ( functor quot -- functor' )
|
||||
GENERIC# $> 1 ( functor quot -- functor' )
|
||||
GENERIC#: fmap 1 ( functor quot -- functor' )
|
||||
GENERIC#: <$ 1 ( functor quot -- functor' )
|
||||
GENERIC#: $> 1 ( functor quot -- functor' )
|
||||
|
||||
! Monads
|
||||
|
||||
|
|
|
@ -214,7 +214,7 @@ PRIVATE>
|
|||
: key-spec ( spec-quot -- spec-assoc )
|
||||
output>array >hashtable ; inline
|
||||
|
||||
GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
|
||||
GENERIC#: hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
|
||||
|
||||
M: mdb-query-msg hint
|
||||
>>hint ;
|
||||
|
|
|
@ -42,8 +42,8 @@ C: <end> end
|
|||
[ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
|
||||
|
||||
GENERIC: merge ( t t -- t )
|
||||
GENERIC# block-merge 1 ( t t -- t )
|
||||
GENERIC# end-merge 1 ( t t -- t )
|
||||
GENERIC#: block-merge 1 ( t t -- t )
|
||||
GENERIC#: end-merge 1 ( t t -- t )
|
||||
M: block merge block-merge ;
|
||||
M: end merge end-merge ;
|
||||
M: block block-merge [ [ two>> ] bi@ merge ]
|
||||
|
|
|
@ -34,7 +34,7 @@ IN: tools.dns
|
|||
[ dns-AAAA-query aaaa-message. ]
|
||||
[ dns-MX-query mx-message. ] tri ;
|
||||
|
||||
GENERIC# dns-host 1 ( servers domain -- )
|
||||
GENERIC#: dns-host 1 ( servers domain -- )
|
||||
|
||||
M: sequence dns-host ( servers domain -- )
|
||||
'[ _ host ] with-dns-servers ;
|
||||
|
|
|
@ -55,7 +55,7 @@ SYNTAX: VARIANT-MEMBER:
|
|||
MACRO: unboa ( class -- quot )
|
||||
<wrapper> \ boa [ ] 2sequence [undo] ;
|
||||
|
||||
GENERIC# (match-branch) 1 ( class quot -- class quot' )
|
||||
GENERIC#: (match-branch) 1 ( class quot -- class quot' )
|
||||
|
||||
M: singleton-class (match-branch)
|
||||
\ drop prefix ;
|
||||
|
|
|
@ -34,8 +34,8 @@ MEMO: zmq-msg-size ( -- x )
|
|||
: <zmq_msg_t> ( -- byte-array )
|
||||
zmq-msg-size (byte-array) ;
|
||||
|
||||
GENERIC# zmq-setopt 2 ( obj name value -- )
|
||||
GENERIC# zmq-getopt 1 ( obj name -- value )
|
||||
GENERIC#: zmq-setopt 2 ( obj name value -- )
|
||||
GENERIC#: zmq-getopt 1 ( obj name -- value )
|
||||
|
||||
TUPLE: zmq-message underlying ;
|
||||
|
||||
|
|
|
@ -66,11 +66,11 @@ GENERIC: >layout ( gadget -- layout )
|
|||
M: gadget >layout f <layout> ;
|
||||
M: layout >layout ;
|
||||
|
||||
GENERIC# (add-gadget-at) 2 ( parent item n -- )
|
||||
GENERIC#: (add-gadget-at) 2 ( parent item n -- )
|
||||
M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
|
||||
M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
|
||||
|
||||
GENERIC# add-gadget-at 1 ( item location -- )
|
||||
GENERIC#: add-gadget-at 1 ( item location -- )
|
||||
M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
|
||||
M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
|
||||
[ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip model<< ] if ] if ;
|
||||
|
|
Loading…
Reference in New Issue