New convention for parametrized constructors: new-* instead of construct-*

db4
Slava Pestov 2008-04-14 05:07:31 -05:00
parent d42ae9508f
commit 70bec926d0
19 changed files with 47 additions and 44 deletions

View File

@ -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 ;

View File

@ -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" } ;

View File

@ -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> ;

View File

@ -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

View File

@ -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"

View File

@ -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 } "." } ;

View File

@ -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 ;

View File

@ -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

View File

@ -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
[

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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