New convention for parametrized constructors: new-* instead of construct-*
parent
d42ae9508f
commit
70bec926d0
|
@ -18,12 +18,12 @@ boxer prep unboxer
|
|||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: construct-c-type ( class -- type )
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type construct-c-type ;
|
||||
\ c-type new-c-type ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
@ -189,7 +189,7 @@ DEFER: >c-ushort-array
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type construct-c-type ;
|
||||
long-long-type new-c-type ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
|
@ -32,23 +32,23 @@ $nl
|
|||
""
|
||||
": add-occupant ( person vehicle -- ) occupants>> push ;"
|
||||
""
|
||||
": construct-vehicle ( class -- vehicle )"
|
||||
": new-vehicle ( class -- vehicle )"
|
||||
" new"
|
||||
" V{ } clone >>occupants ;"
|
||||
""
|
||||
"TUPLE: car < vehicle engine ;"
|
||||
": <car> ( max-speed engine -- car )"
|
||||
" car construct-vehicle"
|
||||
" car new-vehicle"
|
||||
" swap >>engine"
|
||||
" swap >>max-speed ;"
|
||||
""
|
||||
"TUPLE: aeroplane < vehicle max-altitude ;"
|
||||
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
|
||||
" aeroplane construct-vehicle"
|
||||
" aeroplane new-vehicle"
|
||||
" swap >>max-altitude"
|
||||
" swap >>max-speed ;"
|
||||
}
|
||||
"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
|
||||
"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
|
||||
|
||||
ARTICLE: "tuple-constructors" "Tuple constructors"
|
||||
"Tuples are created by calling one of two constructor primitives:"
|
||||
|
@ -64,13 +64,16 @@ $nl
|
|||
{ $code
|
||||
"TUPLE: color red green blue alpha ;"
|
||||
""
|
||||
"! The following two are equivalent"
|
||||
"C: <rgba> rgba"
|
||||
": <rgba> color boa ; ! identical to above"
|
||||
": <rgba> color boa ;"
|
||||
""
|
||||
"! We can define constructors which call other constructors"
|
||||
": <rgb> f <rgba> ;"
|
||||
""
|
||||
": <color> new ;"
|
||||
": <color> f f f f <rgba> ; ! identical to above"
|
||||
"! The following two are equivalent"
|
||||
": <color> color new ;"
|
||||
": <color> f f f f <rgba> ;"
|
||||
}
|
||||
{ $subsection "parametrized-constructors" } ;
|
||||
|
||||
|
|
|
@ -237,7 +237,7 @@ M: phantom-stack clone
|
|||
|
||||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: construct-phantom-stack ( class -- stack )
|
||||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc)
|
||||
|
@ -257,7 +257,7 @@ GENERIC: <loc> ( n stack -- loc )
|
|||
TUPLE: phantom-datastack < phantom-stack ;
|
||||
|
||||
: <phantom-datastack> ( -- stack )
|
||||
phantom-datastack construct-phantom-stack ;
|
||||
phantom-datastack new-phantom-stack ;
|
||||
|
||||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
||||
|
||||
|
@ -267,7 +267,7 @@ M: phantom-datastack finalize-height
|
|||
TUPLE: phantom-retainstack < phantom-stack ;
|
||||
|
||||
: <phantom-retainstack> ( -- stack )
|
||||
phantom-retainstack construct-phantom-stack ;
|
||||
phantom-retainstack new-phantom-stack ;
|
||||
|
||||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
||||
|
||||
|
|
|
@ -17,14 +17,14 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
0 >>column
|
||||
drop ;
|
||||
|
||||
: construct-lexer ( text class -- lexer )
|
||||
construct-empty
|
||||
: new-lexer ( text class -- lexer )
|
||||
new
|
||||
0 >>line
|
||||
swap >>text
|
||||
dup next-line ; inline
|
||||
|
||||
: <lexer> ( text -- lexer )
|
||||
lexer construct-lexer ;
|
||||
lexer new-lexer ;
|
||||
|
||||
: location ( -- loc )
|
||||
file get lexer get lexer-line 2dup and
|
||||
|
|
|
@ -60,8 +60,8 @@ $nl
|
|||
{ $subsection short-section }
|
||||
{ $subsection long-section }
|
||||
"Utilities to use when implementing sections:"
|
||||
{ $subsection construct-section }
|
||||
{ $subsection construct-block }
|
||||
{ $subsection new-section }
|
||||
{ $subsection new-block }
|
||||
{ $subsection add-section } ;
|
||||
|
||||
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
|
||||
|
|
|
@ -78,7 +78,7 @@ HELP: section
|
|||
{ { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
|
||||
} } ;
|
||||
|
||||
HELP: construct-section
|
||||
HELP: new-section
|
||||
{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
|
||||
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
|
||||
|
||||
|
|
|
@ -71,7 +71,7 @@ start end
|
|||
start-group? end-group?
|
||||
style overhang ;
|
||||
|
||||
: construct-section ( length class -- section )
|
||||
: new-section ( length class -- section )
|
||||
new
|
||||
position get >>start
|
||||
swap position [ + ] change
|
||||
|
@ -127,7 +127,7 @@ M: object short-section? section-fits? ;
|
|||
TUPLE: line-break < section type ;
|
||||
|
||||
: <line-break> ( type -- section )
|
||||
0 \ line-break construct-section
|
||||
0 \ line-break new-section
|
||||
swap >>type ;
|
||||
|
||||
M: line-break short-section drop ;
|
||||
|
@ -137,13 +137,13 @@ M: line-break long-section drop ;
|
|||
! Block sections
|
||||
TUPLE: block < section sections ;
|
||||
|
||||
: construct-block ( style class -- block )
|
||||
0 swap construct-section
|
||||
: new-block ( style class -- block )
|
||||
0 swap new-section
|
||||
V{ } clone >>sections
|
||||
swap >>style ; inline
|
||||
|
||||
: <block> ( style -- block )
|
||||
block construct-block ;
|
||||
block new-block ;
|
||||
|
||||
: pprinter-block ( -- block ) pprinter-stack get peek ;
|
||||
|
||||
|
@ -200,7 +200,7 @@ M: block short-section ( block -- )
|
|||
TUPLE: text < section string ;
|
||||
|
||||
: <text> ( string style -- text )
|
||||
over length 1+ \ text construct-section
|
||||
over length 1+ \ text new-section
|
||||
swap >>style
|
||||
swap >>string ;
|
||||
|
||||
|
@ -216,7 +216,7 @@ M: text long-section short-section ;
|
|||
TUPLE: inset < block narrow? ;
|
||||
|
||||
: <inset> ( narrow? -- block )
|
||||
H{ } inset construct-block
|
||||
H{ } inset new-block
|
||||
2 >>overhang
|
||||
swap >>narrow? ;
|
||||
|
||||
|
@ -237,7 +237,7 @@ M: inset newline-after? drop t ;
|
|||
TUPLE: flow < block ;
|
||||
|
||||
: <flow> ( -- block )
|
||||
H{ } flow construct-block ;
|
||||
H{ } flow new-block ;
|
||||
|
||||
M: flow short-section? ( section -- ? )
|
||||
#! If we can make room for this entire block by inserting
|
||||
|
@ -253,7 +253,7 @@ M: flow short-section? ( section -- ? )
|
|||
TUPLE: colon < block ;
|
||||
|
||||
: <colon> ( -- block )
|
||||
H{ } colon construct-block ;
|
||||
H{ } colon new-block ;
|
||||
|
||||
M: colon long-section short-section ;
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ M: object init-session* drop ;
|
|||
|
||||
TUPLE: session-manager responder sessions ;
|
||||
|
||||
: construct-session-manager ( responder class -- responder' )
|
||||
: new-session-manager ( responder class -- responder' )
|
||||
new
|
||||
<sessions-in-memory> >>sessions
|
||||
swap >>responder ; inline
|
||||
|
@ -68,7 +68,7 @@ M: session-saver dispose
|
|||
TUPLE: null-sessions < session-manager ;
|
||||
|
||||
: <null-sessions>
|
||||
null-sessions construct-session-manager ;
|
||||
null-sessions new-session-manager ;
|
||||
|
||||
M: null-sessions call-responder ( path responder -- response )
|
||||
H{ } clone f call-responder/session ;
|
||||
|
@ -76,7 +76,7 @@ M: null-sessions call-responder ( path responder -- response )
|
|||
TUPLE: url-sessions < session-manager ;
|
||||
|
||||
: <url-sessions> ( responder -- responder' )
|
||||
url-sessions construct-session-manager ;
|
||||
url-sessions new-session-manager ;
|
||||
|
||||
: session-id-key "factorsessid" ;
|
||||
|
||||
|
@ -111,7 +111,7 @@ M: url-sessions call-responder ( path responder -- response )
|
|||
TUPLE: cookie-sessions < session-manager ;
|
||||
|
||||
: <cookie-sessions> ( responder -- responder' )
|
||||
cookie-sessions construct-session-manager ;
|
||||
cookie-sessions new-session-manager ;
|
||||
|
||||
: current-cookie-session ( responder -- id namespace/f )
|
||||
request get session-id-key get-cookie dup
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: http.server.templating.fhtml
|
|||
TUPLE: template-lexer < lexer ;
|
||||
|
||||
: <template-lexer> ( lines -- lexer )
|
||||
template-lexer construct-lexer ;
|
||||
template-lexer new-lexer ;
|
||||
|
||||
M: template-lexer skip-word
|
||||
[
|
||||
|
|
|
@ -27,7 +27,7 @@ M: monitor timeout timeout>> ;
|
|||
|
||||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: construct-monitor ( path mailbox class -- monitor )
|
||||
: new-monitor ( path mailbox class -- monitor )
|
||||
new
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
|
|
@ -21,7 +21,7 @@ M: dummy-monitor dispose
|
|||
M: mock-io-backend (monitor)
|
||||
nip
|
||||
over exists? [
|
||||
dummy-monitor construct-monitor
|
||||
dummy-monitor new-monitor
|
||||
dummy-monitor-created get [ 1+ ] change-i drop
|
||||
] [
|
||||
"Does not exist" throw
|
||||
|
|
|
@ -98,7 +98,7 @@ M: recursive-monitor dispose
|
|||
|
||||
: <recursive-monitor> ( path mailbox -- monitor )
|
||||
>r (normalize-path) r>
|
||||
recursive-monitor construct-monitor
|
||||
recursive-monitor new-monitor
|
||||
H{ } clone >>children
|
||||
<promise> >>ready
|
||||
dup start-pump-thread
|
||||
|
|
|
@ -32,7 +32,7 @@ M: input-task io-task-container drop reads>> ;
|
|||
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: construct-mx ( class -- obj )
|
||||
: new-mx ( class -- obj )
|
||||
new
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
|
|
@ -13,7 +13,7 @@ TUPLE: epoll-mx < mx events ;
|
|||
256 ; inline
|
||||
|
||||
: <epoll-mx> ( -- mx )
|
||||
epoll-mx construct-mx
|
||||
epoll-mx new-mx
|
||||
max-events epoll_create dup io-error over set-mx-fd
|
||||
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: kqueue-mx < mx events monitors ;
|
|||
256 ; inline
|
||||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx construct-mx
|
||||
kqueue-mx new-mx
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <c-array> >>events ;
|
||||
|
@ -142,7 +142,7 @@ TUPLE: vnode-monitor < monitor fd ;
|
|||
|
||||
: <vnode-monitor> ( path mailbox -- monitor )
|
||||
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||
vnode-monitor construct-monitor swap >>fd
|
||||
vnode-monitor new-monitor swap >>fd
|
||||
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||
|
||||
M: vnode-monitor dispose
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: io.unix.linux.monitors
|
|||
TUPLE: linux-monitor < monitor wd ;
|
||||
|
||||
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||
linux-monitor construct-monitor
|
||||
linux-monitor new-monitor
|
||||
swap >>wd ;
|
||||
|
||||
SYMBOL: watches
|
||||
|
|
|
@ -13,7 +13,7 @@ TUPLE: macosx-monitor < monitor handle ;
|
|||
] curry each ;
|
||||
|
||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||
path mailbox macosx-monitor construct-monitor
|
||||
path mailbox macosx-monitor new-monitor
|
||||
dup [ enqueue-notifications ] curry
|
||||
path 1array 0 0 <event-stream> >>handle ;
|
||||
|
||||
|
|
|
@ -14,7 +14,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||
|
||||
: <select-mx> ( -- mx )
|
||||
select-mx construct-mx
|
||||
select-mx new-mx
|
||||
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||
|
||||
|
|
|
@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
|
||||
M:: winnt (monitor) ( path recursive? mailbox -- monitor )
|
||||
[
|
||||
path mailbox win32-monitor construct-monitor
|
||||
path mailbox win32-monitor new-monitor
|
||||
path open-directory \ win32-monitor-port <buffered-port>
|
||||
recursive? >>recursive
|
||||
>>port
|
||||
|
|
Loading…
Reference in New Issue