factor: slot:
parent
9910c373c2
commit
7f0d6f34a7
|
@ -43,7 +43,7 @@ M: slice >c-ptr
|
||||||
[ [ from>> ] [ element-size ] bi * ] [ seq>> >c-ptr ] bi
|
[ [ from>> ] [ element-size ] bi * ] [ seq>> >c-ptr ] bi
|
||||||
<displaced-alien> ; inline
|
<displaced-alien> ; inline
|
||||||
|
|
||||||
SLOT: underlying
|
slot: underlying
|
||||||
|
|
||||||
M: object >c-ptr underlying>> ; inline
|
M: object >c-ptr underlying>> ; inline
|
||||||
|
|
||||||
|
|
|
@ -303,10 +303,10 @@ ARTICLE: "protocol-slots" "Protocol slots"
|
||||||
"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot."
|
"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot."
|
||||||
$nl
|
$nl
|
||||||
"Protocol slots are defined using a parsing word:"
|
"Protocol slots are defined using a parsing word:"
|
||||||
{ $subsections postpone: SLOT: }
|
{ $subsections postpone: slot: }
|
||||||
"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
|
"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
|
||||||
$nl
|
$nl
|
||||||
"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots: " { $snippet "SLOT: length" } " and " { $snippet "SLOT: underlying" } ". "
|
"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots: " { $snippet "slot: length" } " and " { $snippet "slot: underlying" } ". "
|
||||||
"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations."
|
"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations."
|
||||||
$nl
|
$nl
|
||||||
"For example, compare the definitions of the " { $link sbuf } " class,"
|
"For example, compare the definitions of the " { $link sbuf } " class,"
|
||||||
|
|
|
@ -631,10 +631,10 @@ M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
|
||||||
{ } [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
|
{ } [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
|
||||||
|
|
||||||
defer: change-slot-test
|
defer: change-slot-test
|
||||||
SLOT: kex
|
slot: kex
|
||||||
|
|
||||||
{ } [
|
{ } [
|
||||||
"in: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
|
"in: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; slot: kex M: change-slot-test kex>> drop 3 ;"
|
||||||
<string-reader> "change-slot-test" parse-stream
|
<string-reader> "change-slot-test" parse-stream
|
||||||
drop
|
drop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -650,7 +650,7 @@ SLOT: kex
|
||||||
{ t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
|
{ t } [ \ change-slot-test \ kex>> ?lookup-method >boolean ] unit-test
|
||||||
|
|
||||||
{ } [
|
{ } [
|
||||||
"in: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
|
"in: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; slot: kex M: change-slot-test kex>> drop 3 ;"
|
||||||
<string-reader> "change-slot-test" parse-stream
|
<string-reader> "change-slot-test" parse-stream
|
||||||
drop
|
drop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -145,7 +145,7 @@ PROTOCOL: silly-protocol do-me ;
|
||||||
|
|
||||||
! A slot protocol issue
|
! A slot protocol issue
|
||||||
defer: slot-protocol-test-3
|
defer: slot-protocol-test-3
|
||||||
SLOT: y
|
slot: y
|
||||||
|
|
||||||
{ f } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
|
{ f } [ \ slot-protocol-test-3 \ y>> ?lookup-method >boolean ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -12,7 +12,7 @@ symbol: debug-leaks?
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
SLOT: continuation
|
slot: continuation
|
||||||
|
|
||||||
: register-disposable ( obj -- )
|
: register-disposable ( obj -- )
|
||||||
debug-leaks? get-global [ current-continuation >>continuation ] when
|
debug-leaks? get-global [ current-continuation >>continuation ] when
|
||||||
|
|
|
@ -6,8 +6,8 @@ in: growable
|
||||||
|
|
||||||
mixin: growable
|
mixin: growable
|
||||||
|
|
||||||
SLOT: length
|
slot: length
|
||||||
SLOT: underlying
|
slot: underlying
|
||||||
|
|
||||||
M: growable length length>> ; inline
|
M: growable length length>> ; inline
|
||||||
M: growable nth-unsafe underlying>> nth-unsafe ; inline
|
M: growable nth-unsafe underlying>> nth-unsafe ; inline
|
||||||
|
|
|
@ -6,8 +6,8 @@ sequences.private strings ;
|
||||||
in: io.streams.sequence
|
in: io.streams.sequence
|
||||||
|
|
||||||
! Readers
|
! Readers
|
||||||
SLOT: underlying
|
slot: underlying
|
||||||
SLOT: i
|
slot: i
|
||||||
|
|
||||||
: >sequence-stream< ( stream -- i underlying )
|
: >sequence-stream< ( stream -- i underlying )
|
||||||
[ i>> ] [ underlying>> ] bi ; inline
|
[ i>> ] [ underlying>> ] bi ; inline
|
||||||
|
|
|
@ -19,7 +19,7 @@ TUPLE: hello length ;
|
||||||
[ "xyz" 4 >>length ] [ no-method? ] must-fail-with
|
[ "xyz" 4 >>length ] [ no-method? ] must-fail-with
|
||||||
|
|
||||||
! Test protocol slots
|
! Test protocol slots
|
||||||
SLOT: my-protocol-slot-test
|
slot: my-protocol-slot-test
|
||||||
|
|
||||||
TUPLE: protocol-slot-test-tuple x ;
|
TUPLE: protocol-slot-test-tuple x ;
|
||||||
|
|
||||||
|
|
|
@ -789,8 +789,8 @@ HELP: read-only
|
||||||
|
|
||||||
{ initial: read-only } related-words
|
{ initial: read-only } related-words
|
||||||
|
|
||||||
HELP: SLOT:
|
HELP: slot:
|
||||||
{ $syntax "SLOT: name" }
|
{ $syntax "slot: name" }
|
||||||
{ $values { "name" "a slot name" } }
|
{ $values { "name" "a slot name" } }
|
||||||
{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." } ;
|
{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." } ;
|
||||||
|
|
||||||
|
|
|
@ -243,7 +243,7 @@ in: bootstrap.syntax
|
||||||
|
|
||||||
"INSTANCE:" [
|
"INSTANCE:" [
|
||||||
location [
|
location [
|
||||||
scan-word scan-word 2dup add-mixin-instance
|
scan-word scan-word ";" expect 2dup add-mixin-instance
|
||||||
<mixin-instance>
|
<mixin-instance>
|
||||||
] dip remember-definition
|
] dip remember-definition
|
||||||
] define-core-syntax
|
] define-core-syntax
|
||||||
|
|
|
@ -20,9 +20,9 @@ FROM: mongodb.tuple => +transient+ +load+ <tuple-index> ;
|
||||||
|
|
||||||
mixin: mdb-persistent
|
mixin: mdb-persistent
|
||||||
|
|
||||||
SLOT: id
|
slot: id
|
||||||
SLOT: _id
|
slot: _id
|
||||||
SLOT: _mfd
|
slot: _mfd
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
|
@ -258,7 +258,7 @@ M: float-11-11-10-components (component-type>type)
|
||||||
: image-data-format ( component-order component-type -- gl-format gl-type )
|
: image-data-format ( component-order component-type -- gl-format gl-type )
|
||||||
[ (component-order>format) ] [ (component-type>type) ] 2bi ;
|
[ (component-order>format) ] [ (component-type>type) ] 2bi ;
|
||||||
|
|
||||||
SLOT: display-list
|
slot: display-list
|
||||||
|
|
||||||
: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
|
: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
|
||||||
|
|
||||||
|
|
|
@ -106,7 +106,7 @@ M: sessions call-responder* ( path responder -- response )
|
||||||
request-session [ begin-session ] unless*
|
request-session [ begin-session ] unless*
|
||||||
existing-session put-session-cookie ;
|
existing-session put-session-cookie ;
|
||||||
|
|
||||||
SLOT: session
|
slot: session
|
||||||
|
|
||||||
: check-session ( state/f -- state/f )
|
: check-session ( state/f -- state/f )
|
||||||
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
||||||
|
|
|
@ -53,7 +53,7 @@ PRIVATE>
|
||||||
{ T{ drag } [ update-clicked drop ] }
|
{ T{ drag } [ update-clicked drop ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
SLOT: popup
|
slot: popup
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ in: ui.gadgets.labels
|
||||||
! A label gadget draws a string.
|
! A label gadget draws a string.
|
||||||
TUPLE: label < aligned-gadget text font ;
|
TUPLE: label < aligned-gadget text font ;
|
||||||
|
|
||||||
SLOT: string
|
slot: string
|
||||||
|
|
||||||
M: label string>> ( label -- string )
|
M: label string>> ( label -- string )
|
||||||
text>> dup string? [ "\n" join ] unless ; inline
|
text>> dup string? [ "\n" join ] unless ; inline
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors io.pathnames sequences ui.images ui.theme ;
|
USING: accessors io.pathnames sequences ui.images ui.theme ;
|
||||||
in: ui.gadgets.theme
|
in: ui.gadgets.theme
|
||||||
|
|
||||||
SLOT: font ! Temporarily necessary to fix Windows bootstrap.
|
slot: font ! Temporarily necessary to fix Windows bootstrap.
|
||||||
|
|
||||||
: theme-image ( name -- image-name )
|
: theme-image ( name -- image-name )
|
||||||
"vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
|
"vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
|
||||||
|
|
|
@ -27,7 +27,7 @@ symbol: viewport-translation
|
||||||
[ clip namespaces:set ] bi
|
[ clip namespaces:set ] bi
|
||||||
do-clip ;
|
do-clip ;
|
||||||
|
|
||||||
SLOT: background-color
|
slot: background-color
|
||||||
|
|
||||||
: gl-init ( -- )
|
: gl-init ( -- )
|
||||||
check-extensions "1.0" require-gl-version
|
check-extensions "1.0" require-gl-version
|
||||||
|
|
|
@ -39,7 +39,7 @@ links-popup H{
|
||||||
{ T{ key-down f f "ESC" } [ hide-glass ] }
|
{ T{ key-down f f "ESC" } [ hide-glass ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
SLOT: model
|
slot: model
|
||||||
|
|
||||||
: show-links-popup ( browser-gadget quot title -- )
|
: show-links-popup ( browser-gadget quot title -- )
|
||||||
[ dup model>> ] 2dip <links-popup>
|
[ dup model>> ] 2dip <links-popup>
|
||||||
|
|
|
@ -26,7 +26,7 @@ M: tool layout*
|
||||||
[ [ dim>> ] [ class-of ] bi set-tool-dim ]
|
[ [ dim>> ] [ class-of ] bi set-tool-dim ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
SLOT: scroller
|
slot: scroller
|
||||||
|
|
||||||
: com-page-up ( tool -- )
|
: com-page-up ( tool -- )
|
||||||
scroller>> scroll-up-page ;
|
scroller>> scroll-up-page ;
|
||||||
|
|
|
@ -14,8 +14,8 @@ ui.tools.listener.popups vocabs words ;
|
||||||
in: ui.tools.listener.completion
|
in: ui.tools.listener.completion
|
||||||
|
|
||||||
! We don't directly depend on the listener tool but we use a few slots
|
! We don't directly depend on the listener tool but we use a few slots
|
||||||
SLOT: interactor
|
slot: interactor
|
||||||
SLOT: history
|
slot: history
|
||||||
|
|
||||||
: history-list ( interactor -- alist )
|
: history-list ( interactor -- alist )
|
||||||
history>> elements>>
|
history>> elements>>
|
||||||
|
|
|
@ -36,7 +36,7 @@ INSTANCE: interactor input-stream
|
||||||
[ thread>> dup [ thread-registered? ] when ]
|
[ thread>> dup [ thread-registered? ] when ]
|
||||||
} 1&& not ;
|
} 1&& not ;
|
||||||
|
|
||||||
SLOT: manifest
|
slot: manifest
|
||||||
|
|
||||||
M: interactor manifest>>
|
M: interactor manifest>>
|
||||||
dup interactor-busy? [ drop f ] [
|
dup interactor-busy? [ drop f ] [
|
||||||
|
|
|
@ -35,7 +35,7 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
|
||||||
PREDICATE: struct-class < tuple-class
|
PREDICATE: struct-class < tuple-class
|
||||||
superclass-of \ struct eq? ;
|
superclass-of \ struct eq? ;
|
||||||
|
|
||||||
SLOT: fields
|
slot: fields
|
||||||
|
|
||||||
: struct-slots ( struct-class -- slots )
|
: struct-slots ( struct-class -- slots )
|
||||||
"c-type" word-prop fields>> ;
|
"c-type" word-prop fields>> ;
|
||||||
|
|
|
@ -42,8 +42,8 @@ MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
|
||||||
[ struct-slots [ name>> reader-word 1quotation ] map ] keep
|
[ struct-slots [ name>> reader-word 1quotation ] map ] keep
|
||||||
'[ _ cleave _ <struct-boa> ] ;
|
'[ _ cleave _ <struct-boa> ] ;
|
||||||
|
|
||||||
SLOT: (n)
|
slot: (n)
|
||||||
SLOT: (vectored)
|
slot: (vectored)
|
||||||
|
|
||||||
FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
|
FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
|
||||||
|
|
||||||
|
|
|
@ -4,8 +4,8 @@ USING: accessors arrays compiler.cfg compiler.cfg.instructions
|
||||||
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
|
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
|
||||||
kernel make math namespaces sequences ;
|
kernel make math namespaces sequences ;
|
||||||
in: compiler.cfg.builder.blocks
|
in: compiler.cfg.builder.blocks
|
||||||
SLOT: in-d
|
slot: in-d
|
||||||
SLOT: out-d
|
slot: out-d
|
||||||
|
|
||||||
: set-basic-block ( basic-block -- )
|
: set-basic-block ( basic-block -- )
|
||||||
dup begin-local-analysis instructions>> building set ;
|
dup begin-local-analysis instructions>> building set ;
|
||||||
|
|
|
@ -12,7 +12,7 @@ windows.time windows.types windows.winsock ;
|
||||||
SPECIALIZED-ARRAY: ushort
|
SPECIALIZED-ARRAY: ushort
|
||||||
in: io.files.windows
|
in: io.files.windows
|
||||||
|
|
||||||
SLOT: file
|
slot: file
|
||||||
|
|
||||||
: CreateFile-flags ( DWORD -- DWORD )
|
: CreateFile-flags ( DWORD -- DWORD )
|
||||||
flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } bitor ;
|
flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } bitor ;
|
||||||
|
@ -281,7 +281,7 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
||||||
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
||||||
+not-content-indexed+ +encrypted+ ;
|
+not-content-indexed+ +encrypted+ ;
|
||||||
|
|
||||||
SLOT: attributes
|
slot: attributes
|
||||||
|
|
||||||
: read-only? ( file-info -- ? )
|
: read-only? ( file-info -- ? )
|
||||||
attributes>> +read-only+ swap member? ;
|
attributes>> +read-only+ swap member? ;
|
||||||
|
|
|
@ -69,7 +69,7 @@ M: local present path>> "Unix domain socket: " prepend ;
|
||||||
|
|
||||||
M: local protocol drop 0 ;
|
M: local protocol drop 0 ;
|
||||||
|
|
||||||
SLOT: port
|
slot: port
|
||||||
|
|
||||||
TUPLE: ipv4 { host maybe{ string } read-only } ;
|
TUPLE: ipv4 { host maybe{ string } read-only } ;
|
||||||
|
|
||||||
|
|
|
@ -59,7 +59,7 @@ in: http.server.cgi
|
||||||
] with-stream
|
] with-stream
|
||||||
] >>body ;
|
] >>body ;
|
||||||
|
|
||||||
SLOT: special
|
slot: special
|
||||||
|
|
||||||
: enable-cgi ( responder -- responder )
|
: enable-cgi ( responder -- responder )
|
||||||
[ serve-cgi ] "application/x-cgi-script"
|
[ serve-cgi ] "application/x-cgi-script"
|
||||||
|
|
|
@ -39,7 +39,7 @@ C-TYPE: cairo_snurface_t
|
||||||
main: majn
|
main: majn
|
||||||
|
|
||||||
! ! SLOT
|
! ! SLOT
|
||||||
SLOT: komba
|
slot: komba
|
||||||
|
|
||||||
! ! SYNTAX
|
! ! SYNTAX
|
||||||
<<
|
<<
|
||||||
|
|
|
@ -57,12 +57,12 @@ TUPLE: spidering-site < watching-site max-depth max-count ;
|
||||||
|
|
||||||
C: <spidering-site> spidering-site
|
C: <spidering-site> spidering-site
|
||||||
|
|
||||||
SLOT: site
|
slot: site
|
||||||
|
|
||||||
M: watching-site site>>
|
M: watching-site site>>
|
||||||
site-id>> site-with-id ;
|
site-id>> site-with-id ;
|
||||||
|
|
||||||
SLOT: account
|
slot: account
|
||||||
|
|
||||||
M: watching-site account>>
|
M: watching-site account>>
|
||||||
account-name>> account new swap >>account-name select-tuple ;
|
account-name>> account new swap >>account-name select-tuple ;
|
||||||
|
|
|
@ -10,13 +10,13 @@ in: webapps.mason.version.files
|
||||||
: remote-directory ( string -- string' )
|
: remote-directory ( string -- string' )
|
||||||
[ package-directory get ] dip "/" glue ;
|
[ package-directory get ] dip "/" glue ;
|
||||||
|
|
||||||
SLOT: os
|
slot: os
|
||||||
SLOT: cpu
|
slot: cpu
|
||||||
|
|
||||||
: platform ( builder -- string )
|
: platform ( builder -- string )
|
||||||
[ os>> ] [ cpu>> ] bi (platform) ;
|
[ os>> ] [ cpu>> ] bi (platform) ;
|
||||||
|
|
||||||
SLOT: last-release
|
slot: last-release
|
||||||
|
|
||||||
: binary-package-name ( builder -- string )
|
: binary-package-name ( builder -- string )
|
||||||
[ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
|
[ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
|
||||||
|
|
Loading…
Reference in New Issue