pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm )
- check-alarm <box> alarm construct-boa ;
+ check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup alarm-time alarms get-global heap-push*
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element construct-empty ;
+: <element> element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
TUPLE: tag value ;
-: <tag> ( -- <tag> ) 4 tag construct-boa ;
+: <tag> ( -- <tag> ) 4 tag boa ;
: with-ber ( quot -- )
[
"benchmark.dispatch1" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
- my-classes [ construct-empty ] map ;
+ my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects
"benchmark.dispatch5" words [ tuple-class? ] subset ;\r
\r
: a-bunch-of-objects ( -- seq )\r
- my-classes [ construct-empty ] map ;\r
+ my-classes [ new ] map ;\r
\r
: dispatch-benchmark ( -- )\r
1000000 a-bunch-of-objects\r
: foo 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
M: check< summary drop "Number exceeds upper bound" ;
: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< construct-boa throw ] if ;
+ 2dup < [ drop ] [ \ check< boa throw ] if ;
: ?check ( length -- )
safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
TUPLE: axion < particle ;
-: <axion> ( -- axion ) axion construct-empty initialize-particle ;
+: <axion> ( -- axion ) axion new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: hadron < particle ;
-: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
+: <hadron> ( -- hadron ) hadron new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: muon < particle ;
-: <muon> ( -- muon ) muon construct-empty initialize-particle ;
+: <muon> ( -- muon ) muon new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: quark < particle ;
-: <quark> ( -- quark ) quark construct-empty initialize-particle ;
+: <quark> ( -- quark ) quark new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
- bunny-dlist construct-boa ;
+ bunny-dlist boa ;
: <bunny-buffers> ( model -- geom )
{
]
[ first length 3 * ]
[ third length 3 * ]
- } cleave bunny-buffers construct-boa ;
+ } cleave bunny-buffers boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
- cairo-surface>array png construct-boa ;
+ cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
TUPLE: channel receivers senders ;
: <channel> ( -- channel )
- V{ } clone V{ } clone channel construct-boa ;
+ V{ } clone V{ } clone channel boa ;
GENERIC: to ( value channel -- )
GENERIC: from ( channel -- value )
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
- 0 circular construct-boa ;
+ 0 circular boa ;
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a b c ;"
- "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
+ "1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3"
}
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
+ "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4"
}
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
TUPLE: foo a b* c d* e f* ;
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
+[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error construct-boa throw ;
+ dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
TUPLE: selector name object ;
-MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
+MEMO: <selector> ( name -- sel ) f \ selector boa ;
: selector ( selector -- alien )
dup selector-object expired? [
[ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ construct-empty ] curry swap [
+ [ new ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;
\r
: <count-down> ( n -- count-down )\r
dup 0 < [ "Invalid count for count down" throw ] when\r
- <promise> \ count-down construct-boa\r
+ <promise> \ count-down boa\r
dup count-down-check ;\r
\r
: count-down ( count-down -- )\r
TUPLE: exchanger thread object ;\r
\r
: <exchanger> ( -- exchanger )\r
- <box> <box> exchanger construct-boa ;\r
+ <box> <box> exchanger boa ;\r
\r
: exchange ( obj exchanger -- newobj )\r
dup exchanger-thread box-full? [\r
TUPLE: flag value? thread ;
-: <flag> ( -- flag ) f <box> flag construct-boa ;
+: <flag> ( -- flag ) f <box> flag boa ;
: raise-flag ( flag -- )
dup flag-value? [
TUPLE: lock threads owner reentrant? ;\r
\r
: <lock> ( -- lock )\r
- <dlist> f f lock construct-boa ;\r
+ <dlist> f f lock boa ;\r
\r
: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock construct-boa ;\r
+ <dlist> f t lock boa ;\r
\r
<PRIVATE\r
\r
TUPLE: rw-lock readers writers reader# writer ;\r
\r
: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock construct-boa ;\r
+ <dlist> <dlist> 0 f rw-lock boa ;\r
\r
<PRIVATE\r
\r
t >>closed threads>> notify-all ;\r
\r
: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> f mailbox construct-boa ;\r
+ <dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
data>> dlist-empty? ;\r
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous construct-boa ;\r
+ self 256 random-bits synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
: <reply> ( data synchronous -- reply )\r
- synchronous-tag \ reply construct-boa ;\r
+ synchronous-tag \ reply boa ;\r
\r
: synchronous-reply? ( response synchronous -- ? )\r
over reply?\r
TUPLE: promise mailbox ;\r
\r
: <promise> ( -- promise )\r
- <mailbox> promise construct-boa ;\r
+ <mailbox> promise boa ;\r
\r
: promise-fulfilled? ( promise -- ? )\r
promise-mailbox mailbox-empty? not ;\r
\r
: <semaphore> ( n -- semaphore )\r
dup 0 < [ "Cannot have semaphore with negative count" throw ] when\r
- <dlist> semaphore construct-boa ;\r
+ <dlist> semaphore boa ;\r
\r
: wait-to-acquire ( semaphore timeout -- )\r
>r semaphore-threads r> "semaphore" wait ;\r
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
- f event-stream construct-boa ;
+ f event-stream boa ;
M: event-stream dispose
dup closed>> [ drop ] [
TUPLE: coroutine resumecc exitcc ;
: cocreate ( quot -- co )
- coroutine construct-empty
+ coroutine new
dup current-coro associate
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
[ HEX: 10 swap set-cpu-last-interrupt ] keep
0 swap set-cpu-cycles ;
-: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
+: <cpu> ( -- cpu ) cpu new dup reset ;
: (load-rom) ( n ram -- )
read1 [ ! n ram ch
delete-statements ;
: construct-db ( class -- obj )
- construct-empty
+ new
H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
- construct-empty
+ new
swap >>out-params
swap >>in-params
swap >>sql ;
0 >>n drop ;
: construct-result-set ( query handle class -- result-set )
- construct-empty
+ new
swap >>handle
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
swap >>out-params
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
- dup first sql-spec-class construct-empty [
+ dup first sql-spec-class new [
[
>r sql-spec-slot-name r> set-slot-named
] curry 2each
TUPLE: dummy-obj destroyed? ;
-: <dummy-obj> dummy-obj construct-empty ;
+: <dummy-obj> dummy-obj new ;
TUPLE: dummy-destructor obj ;
] if ;
: <destructor> ( obj -- newobj )
- f destructor construct-boa ;
+ f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
TUPLE: vertex value edges ;
: <digraph> ( -- digraph )
- digraph construct-empty H{ } clone over set-delegate ;
+ digraph new H{ } clone over set-delegate ;
: <vertex> ( value -- vertex )
- V{ } clone vertex construct-boa ;
+ V{ } clone vertex boa ;
: add-vertex ( key value digraph -- )
>r <vertex> swap r> set-at ;
[ >array ]
[ 0 <array> ]
[ 1 <array> ] tri
- disjoint-set construct-boa ;
+ disjoint-set boa ;
: equiv-set-size ( a disjoint-set -- n )
[ representative ] keep count ;
[ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
- \ no-edit-hook construct-empty
+ \ no-edit-hook new
editor-restarts throw-restarts
require ;
TUPLE: cursortree cursors ;
: <cursortree> ( seq -- cursortree )
- <gb> cursortree
construct-empty tuck set-delegate <avl>
+ <gb> cursortree
new tuck set-delegate <avl>
over set-cursortree-cursors ;
GENERIC: cursortree-gb ( cursortree -- gb )
M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
+ cursor new tuck set-cursor-tree ;
: make-cursor ( cursortree pos cursor -- cursor )
>r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
+ left-cursor new make-cursor ;
: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
+ right-cursor new make-cursor ;
: cursors ( cursortree -- seq )
cursortree-cursors values concat ;
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
: <gb> ( seq -- gb )
- gb construct-empty
+ gb new
5 over set-gb-min-size
1.5 over set-gb-expand-factor
[ >r length r> set-gb-gap-start ] 2keep
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;
-M: object >link link construct-boa ;
+M: object >link link boa ;
PREDICATE: word-link < link link-name word? ;
TUPLE: article title content loc ;
: <article> ( title content -- article )
- f \ article construct-boa ;
+ f \ article boa ;
M: article article-name article-title ;
TUPLE: no-article name ;
-: no-article ( name -- * ) \ no-article construct-boa throw ;
+: no-article ( name -- * ) \ no-article boa throw ;
M: no-article summary
drop "Help article does not exist" ;
[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
[
- "<" "austin" funky construct-boa write-object
+ "<" "austin" funky boa write-object
] make-html-string
] unit-test
TUPLE: html-sub-stream style stream ;
: (html-sub-stream) ( style stream -- stream )
- html-sub-stream construct-boa
+ html-sub-stream boa
512 <sbuf> <html-stream> over set-delegate ;
: <html-sub-stream> ( style stream class -- stream )
TUPLE: cookie name value path domain expires http-only ;
: <cookie> ( value name -- cookie )
- cookie construct-empty
+ cookie new
swap >>name swap >>value ;
: parse-cookies ( string -- seq )
cookies ;
: <request>
- request construct-empty
+ request new
"1.1" >>version
http-port >>port
H{ } clone >>header
body ;
: <response>
- response construct-empty
+ response new
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
body ;
: <raw-response> ( -- response )
- raw-response construct-empty
+ raw-response new
"1.1" >>version ;
M: raw-response write-response ( respose -- )
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
- action construct-empty\r
+ action new\r
[ ] >>init\r
[ <400> ] >>display\r
[ <400> ] >>submit ;\r
TUPLE: users-in-memory assoc ;\r
\r
: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory construct-boa ;\r
+ H{ } clone users-in-memory boa ;\r
\r
M: users-in-memory get-user ( username provider -- user/f )\r
assoc>> at ;\r
\r
TUPLE: user username realname password email ticket profile ;\r
\r
-: <user> user construct-empty H{ } clone >>profile ;\r
+: <user> user new H{ } clone >>profile ;\r
\r
GENERIC: get-user ( username provider -- user/f )\r
\r
#! A continuation responder is a special type of session\r
#! manager. However it works entirely differently from\r
#! the URL and cookie session managers.\r
- H{ } clone callback-responder construct-boa ;\r
+ H{ } clone callback-responder boa ;\r
\r
TUPLE: callback cont quot expires alarm responder ;\r
\r
] when drop ;\r
\r
: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback construct-boa\r
+ f callback-responder get callback boa\r
dup touch-callback ;\r
\r
: invoke-callback ( callback -- response )\r
\r
TUPLE: test-tuple text number more-text ;\r
\r
-: <test-tuple> test-tuple construct-empty ;\r
+: <test-tuple> test-tuple new ;\r
\r
: <test-form> ( -- form )\r
"test" <form>\r
] if ;
: <component> ( id class -- component )
- \ component construct-empty
+ \ component new
swap construct-delegate
swap >>id ; inline
TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone dispatcher construct-boa ;
+ 404-responder get H{ } clone dispatcher boa ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+ 404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
- >r <sessions-in-memory> session-manager construct-boa
+ >r <sessions-in-memory> session-manager boa
r> construct-delegate ; inline
SYMBOLS: session session-id session-changed? ;
TUPLE: sessions-in-memory sessions alarms ;\r
\r
: <sessions-in-memory> ( -- storage )\r
- H{ } clone H{ } clone sessions-in-memory construct-boa ;\r
+ H{ } clone H{ } clone sessions-in-memory boa ;\r
\r
: cancel-session-timeout ( id storage -- )\r
alarms>> at [ cancel-alarm ] when* ;\r
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
- session construct-empty
+ session new
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- namespace/f )
304 "Not modified" <trivial-response> ;\r
\r
: <file-responder> ( root hook -- responder )\r
- H{ } clone file-responder construct-boa ;\r
+ H{ } clone file-responder boa ;\r
\r
: <static> ( root -- responder )\r
[\r
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
-: empty-cons ( -- cons ) cons construct-empty ;
+: empty-cons ( -- cons ) cons new ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
IN: inverse
TUPLE: fail ;
-: fail ( -- * ) \ fail construct-empty throw ;
+: fail ( -- * ) \ fail new throw ;
M: fail summary drop "Unification failed" ;
: assure ( ? -- ) [ fail ] unless ;
"pop-inverse" set-word-prop ;
TUPLE: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
+: no-inverse ( word -- * ) \ no-inverse new throw ;
M: no-inverse summary
drop "The word cannot be used in pattern matching" ;
: boa-inverse ( class -- quot )
[ deconstruct-pred ] keep slot-readers compose ;
-\ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
+\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
[ tuple>array 1 tail [ ] contains? [ fail ] when ]
compose ;
-\ construct-empty 1 [ ?wrapped empty-inverse ] define-pop-inverse
+\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: writer>reader ( word -- word' )
[ "writing" word-prop "slots" word-prop ] keep
MACRO: matches? ( quot -- ? ) [matches?] ;
TUPLE: no-match ;
-: no-match ( -- * ) \ no-match construct-empty throw ;
+: no-match ( -- * ) \ no-match new throw ;
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
TUPLE: buffer size ptr fill pos ;
: <buffer> ( n -- buffer )
- dup malloc 0 0 buffer construct-boa ;
+ dup malloc 0 0 buffer boa ;
: buffer-free ( buffer -- )
dup buffer-ptr free f swap set-buffer-ptr ;
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit construct-boa ] 2curry dupd curry define ;
+ [ 8-bit boa ] 2curry dupd curry define ;
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
C: strict strict
TUPLE: decode-error ;
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+: decode-error ( -- * ) \ decode-error new throw ;
M: decode-error summary
drop "Error in decoding input stream" ;
SYMBOL: +realtime-priority+
: <process> ( -- process )
- process construct-empty
+ process new
H{ } clone >>environment
+append-environment+ >>environment-mode ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
- \ process-failed construct-boa throw ;
+ \ process-failed boa throw ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
M: monitor set-timeout (>>timeout) ;
: construct-monitor ( path mailbox class -- monitor )
- construct-empty
+ new
swap >>queue
swap >>path ; inline
M: mock-io-backend link-info
global [ link-info ] bind ;
-[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test
-[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test
+[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
+[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
[ ] [
mock-io-backend io-backend [
GENERIC: close-handle ( handle -- )
: <port> ( handle class -- port )
- construct-empty
+ new
swap dup init-handle >>handle ; inline
: <buffered-port> ( handle class -- port )
] curry each ;
: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator construct-boa
+ <dlist> directory-iterator boa
dup path>> over push-directory ;
: next-file ( iter -- file/f )
TUPLE: local path ;
: <local> ( path -- addrspec )
- normalize-path local construct-boa ;
+ normalize-path local boa ;
TUPLE: inet4 host port ;
: io-task-fd port>> handle>> ;
: <io-task> ( port continuation/f class -- task )
- construct-empty
+ new
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
swap >>port ; inline
M: output-task io-task-container drop writes>> ;
: construct-mx ( class -- obj )
- construct-empty
+ new
H{ } clone >>reads
H{ } clone >>writes ; inline
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ;
M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
- r> mmap-open f mapped-file construct-boa ;
+ r> mmap-open f mapped-file boa ;
M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj )
- CreateProcess-args construct-empty
+ CreateProcess-args new
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
- f \ mapped-file construct-boa
+ f \ mapped-file boa
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
- pipe construct-boa
+ pipe boa
] with-destructors ;
: close-pipe ( pipe -- )
M: winnt ((client)) ( addrspec -- client-in client-out )
[
- \ ConnectEx-args construct-empty
+ \ ConnectEx-args new
over make-sockaddr/size pick init-connect
over tcp-socket over set-ConnectEx-args-s*
dup ConnectEx-args-s* add-completion
[
[
check-server-port
- \ AcceptEx-args construct-empty
+ \ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
[ accept-continuation ] keep
M: winnt receive ( datagram -- packet addrspec )
[
check-datagram-port
- \ WSARecvFrom-args construct-empty
+ \ WSARecvFrom-args new
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
[ WSARecvFrom-continuation ] keep
M: winnt send ( packet addrspec datagram -- )
[
check-datagram-send
- \ WSASendTo-args construct-empty
+ \ WSASendTo-args new
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep
[ WSASendTo-continuation ] keep
TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
- f win32-file construct-boa ;
+ f win32-file boa ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;
listeners is-running ;
: <irc-client> ( profile -- irc-client )
f V{ } clone V{ } clone <nick>
- f <channel> <channel> V{ } clone f irc-client construct-boa ;
+ f <channel> <channel> V{ } clone f irc-client boa ;
USE: prettyprint
TUPLE: irc-listener channel ;
! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
! tener la opción de dejar de correr un client??
: <irc-listener> ( quot -- irc-listener )
- <channel> irc-listener construct-boa swap
+ <channel> irc-listener boa swap
[
[ channel>> '[ , from ] ]
[ '[ , curry f spawn drop ] ]
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
- jamshred construct-boa ;
+ jamshred boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
- oint construct-boa ;
+ oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
TUPLE: player name tunnel nearest-segment ;
: <player> ( name -- player )
- f f player construct-boa
+ f f player boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
: turn-player ( player x-radians y-radians -- )
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
- <oint> >r segment construct-boa r> over set-delegate ;
+ <oint> >r segment boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons construct-boa
+ [ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
- memoized-cons construct-boa ;
+ memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
[ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato construct-boa ;
+ dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
[ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
- range construct-boa ;
+ range boa ;
M: range length ( seq -- n )
range-length ;
TUPLE: model-tester hit? ;
-: <model-tester> model-tester construct-empty ;
+: <model-tester> model-tester new ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
value connections dependencies ref locked? ;
: <model> ( value -- model )
- V{ } clone V{ } clone 0 f model construct-boa ;
+ V{ } clone V{ } clone 0 f model boa ;
M: model hashcode* drop model hashcode* ;
TUPLE: sprite loc dim dim2 dlist texture ;
: <sprite> ( loc dim dim2 -- sprite )
- f f sprite construct-boa ;
+ f f sprite boa ;
: sprite-size2 sprite-dim2 first2 ;
swap comment-node present-text ;
: comment, ( ? node text -- )
- rot [ \ comment construct-boa , ] [ 2drop ] if ;
+ rot [ \ comment boa , ] [ 2drop ] if ;
: values% ( prefix values -- )
swap [
TUPLE: ensure-parser test ;
: ensure ( parser -- ensure )
- ensure-parser construct-boa ;
+ ensure-parser boa ;
M: ensure-parser parse ( input parser -- list )
2dup ensure-parser-test parse nil?
TUPLE: ensure-not-parser test ;
: ensure-not ( parser -- ensure )
- ensure-not-parser construct-boa ;
+ ensure-not-parser boa ;
M: ensure-not-parser parse ( input parser -- list )
2dup ensure-not-parser-test parse nil?
>r and-parser-parsers r> suffix
] [
2array
- ] if and-parser construct-boa ;
+ ] if and-parser boa ;
: <and-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ and-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ and-parser boa ] if ;
: and-parser-parse ( list p1 -- list )
swap [
TUPLE: or-parser parsers ;
: <or-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ or-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ or-parser boa ] if ;
: <|> ( parser1 parser2 -- parser )
2array <or-parser> ;
TUPLE: only-first-parser p1 ;
LAZY: only-first ( parser -- parser )
- only-first-parser construct-boa ;
+ only-first-parser boa ;
M: only-first-parser parse ( input parser -- list )
#! Transform a parser into a parser that only yields
just-parser-p1 compiled-parser just-pattern curry ;
MEMO: just ( parser -- parser )
- just-parser construct-boa init-parser ;
+ just-parser boa init-parser ;
: 1token ( ch -- parser ) 1string token ;
SYMBOL: ignore
: <parse-result> ( remaining ast -- parse-result )
- parse-result construct-boa ;
+ parse-result boa ;
SYMBOL: packrat
SYMBOL: pos
PRIVATE>
: token ( string -- parser )
- token-parser construct-boa init-parser ;
+ token-parser boa init-parser ;
: satisfy ( quot -- parser )
- satisfy-parser construct-boa init-parser ;
+ satisfy-parser boa init-parser ;
: range ( min max -- parser )
- range-parser construct-boa init-parser ;
+ range-parser boa init-parser ;
: seq ( seq -- parser )
- seq-parser construct-boa init-parser ;
+ seq-parser boa init-parser ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser construct-boa init-parser ;
+ choice-parser boa init-parser ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
{ } make choice ; inline
: repeat0 ( parser -- parser )
- repeat0-parser construct-boa init-parser ;
+ repeat0-parser boa init-parser ;
: repeat1 ( parser -- parser )
- repeat1-parser construct-boa init-parser ;
+ repeat1-parser boa init-parser ;
: optional ( parser -- parser )
- optional-parser construct-boa init-parser ;
+ optional-parser boa init-parser ;
: semantic ( parser quot -- parser )
- semantic-parser construct-boa init-parser ;
+ semantic-parser boa init-parser ;
: ensure ( parser -- parser )
- ensure-parser construct-boa init-parser ;
+ ensure-parser boa init-parser ;
: ensure-not ( parser -- parser )
- ensure-not-parser construct-boa init-parser ;
+ ensure-not-parser boa init-parser ;
: action ( parser quot -- parser )
- action-parser construct-boa init-parser ;
+ action-parser boa init-parser ;
: sp ( parser -- parser )
- sp-parser construct-boa init-parser ;
+ sp-parser boa init-parser ;
: hide ( parser -- parser )
[ drop ignore ] action ;
: delay ( quot -- parser )
- delay-parser construct-boa init-parser ;
+ delay-parser boa init-parser ;
: box ( quot -- parser )
#! because a box has its quotation run at compile time
#! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed...
- box-parser
construct-boa next-id f <parser> over set-delegate [ ] action ;
+ box-parser boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <processing-gadget> ( -- gadget )
- processing-gadget construct-empty
+ processing-gadget new
<frame-buffer> set-gadget-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: promise quot forced? value ;
: promise ( quot -- promise )
- f f \ promise construct-boa ;
+ f f \ promise boa ;
: promise-with ( value quot -- promise )
curry promise ;
: <blum-blum-shub> ( numbits -- blum-blum-shub )
generate-bbs-primes *
[ find-relative-prime ] keep
- blum-blum-shub construct-boa ;
+ blum-blum-shub boa ;
: next-bbs-bit ( bbs -- bit )
[ [ x>> 2 ] [ n>> ] bi ^mod ] keep
PRIVATE>
: <mersenne-twister> ( seed -- obj )
- init-mt-seq 0 mersenne-twister construct-boa
+ init-mt-seq 0 mersenne-twister boa
dup mt-generate ;
M: mersenne-twister seed-random ( mt seed -- )
ignore-case? [
dup 'regexp' just parse-1
] with-variable
- ] keep regexp construct-boa ;
+ ] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
dup 1 3999 between? [
drop
] [
- roman-range-error construct-boa throw
+ roman-range-error boa throw
] if ;
: roman<= ( ch1 ch2 -- ? )
TUPLE: node id content ;
: <node> ( content -- node )
- node construct-empty swap >>content ;
+ node new swap >>content ;
: <id-node> ( id -- node )
- node construct-empty swap >>id ;
+ node new swap >>id ;
node "node"
{
TUPLE: arc id relation subject object ;
: <arc> ( relation subject object -- arc )
- arc construct-empty swap >>object swap >>subject swap >>relation ;
+ arc new swap >>object swap >>subject swap >>relation ;
: <id-arc> ( id -- arc )
- arc construct-empty swap >>id ;
+ arc new swap >>id ;
: insert-arc ( arc -- )
f <node> dup insert-tuple id>> >>id insert-tuple ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
#! slots
- (deserialize) construct-empty
+ (deserialize) new
[ intern-object ]
[
[ (deserialize) ]
message-id "Message-Id" set-header ;
: <email> ( -- email )
- email construct-empty
+ email new
H{ } clone >>headers ;
: send-email ( email -- )
TUPLE: state place data ;
TUPLE: missing-state ;
-: missing-state \ missing-state construct-empty throw ;
+: missing-state \ missing-state new throw ;
M: missing-state error.
drop "Missing state" print ;
! * Errors\r
TUPLE: parsing-error line column ;\r
: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error construct-boa ;\r
+ get-line get-column parsing-error boa ;\r
\r
: construct-parsing-error ( ... slots class -- error )\r
construct <parsing-error> over set-delegate ; inline\r
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-: <tar-header> ( -- obj ) tar-header construct-empty ;
+: <tar-header> ( -- obj ) tar-header new ;
: tar-trim ( seq -- newseq )
[ "\0 " member? ] trim ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
2drop
- \ tar-header construct-empty
+ \ tar-header new
0 over set-tar-header-size
0 over set-tar-header-checksum
] [
[ read-tar-header ] with-string-reader
[ tar-header-checksum = [
- \ checksum-error construct-empty throw
+ \ checksum-error new throw
] unless
] keep
] if ;
TUPLE: tax-table single married ;
: <tax-table> ( single married class -- obj )
- >r tax-table construct-boa r> construct-delegate ;
+ >r tax-table boa r> construct-delegate ;
: tax-bracket-range dup second swap first - ;
[ drop f <array> ] with map ;
: <board> ( width height -- board )
- 2dup make-rows board construct-boa ;
+ 2dup make-rows board boa ;
#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
TUPLE: avl-node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node construct-boa tuck set-delegate ;
+ swap <node> 0 avl-node boa tuck set-delegate ;
: change-balance ( node amount -- )
over avl-node-balance + swap set-avl-node-balance ;
2dup get-splay [ 2nip set-node-value ] [
drop dup inc-count
2dup splay-split rot
- >r >r swapd r> node construct-boa r> set-tree-root
+ >r >r swapd r> node boa r> set-tree-root
] if ;
: new-root ( value key tree -- )
TUPLE: tree root count ;
: <tree> ( -- tree )
- f 0 tree construct-boa ;
+ f 0 tree boa ;
: construct-tree ( class -- tree )
- construct-empty <tree> over set-delegate ; inline
+ new <tree> over set-delegate ; inline
INSTANCE: tree tree-mixin
TUPLE: node key value left right ;
: <node> ( key value -- node )
- f f node construct-boa ;
+ f f node boa ;
SYMBOL: current-side
[ scan-object pick rot set-slot parse-slots ] when* ;
: TUPLE{
- scan-word construct-empty parse-slots parsed ; parsing
+ scan-word new parse-slots parsed ; parsing
TUPLE: turtle ;
: <turtle> ( -- turtle )
-turtle construct-empty
+turtle new
{ 0 0 0 } clone <pos>
3 identity-matrix <ori>
rot
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard construct-boa ;
+: <clipboard> "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
TUPLE: border size fill ;
: <border> ( child gap -- border )
- dup 2array { 0 0 } border construct-boa
+ dup 2array { 0 0 } border boa
<gadget> over set-delegate
tuck add-gadget ;
} set-gestures
: <button> ( gadget quot -- button )
- button construct-empty
+ button new
[ set-button-quot ] keep
[ set-gadget-delegate ] keep ;
: <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
- repeat-button construct-empty
+ repeat-button new
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ;
: @bottom-right 2 2 ;
: <frame> ( -- frame )
- frame construct-empty
+ frame new
<frame-grid> <grid> over set-gadget-delegate ;
: (fill-center) ( vec n -- )
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
- 0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+ 0 0 mock-gadget boa <gadget> over set-delegate ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
- labelled-gadget construct-empty
+ labelled-gadget new
[
<label> dup reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
[ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget construct-empty
+ closable-gadget new
[
<title-bar> @top frame,
g-> set-closable-gadget-content @center frame,
selection-color swap set-pane-selection-color ;
: <pane> ( -- pane )
- pane construct-empty
+ pane new
<pile> over set-delegate
<shelf> over set-pane-prototype
<pile> <incremental> over add-output
dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button )
- presentation construct-empty
+ presentation new
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
} define-command
: <slot-editor> ( ref -- gadget )
- slot-editor construct-empty
+ slot-editor new
[ set-slot-editor-ref ] keep
[
toolbar,
} set-gestures
: <editable-slot> ( gadget ref -- editable-slot )
- editable-slot construct-empty
+ editable-slot new
{ 1 0 } <track> over set-gadget-delegate
[ drop <gadget> ] over set-editable-slot-printer
[ set-editable-slot-ref ] keep
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> construct-boa ; inline
+ >r [ S+ rot remove swap ] unless r> boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
: my-pprint pprint ;
-[ drop t ] \ my-pprint [ ] [ ] f operation construct-boa "op" set
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
[ [ 3 my-pprint ] ] [
3 "op" get operation-command command-quot
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
"op" set
[ "\"4\"" ] [
swap set-browser-gadget-history ;
: <browser-gadget> ( -- gadget )
- browser-gadget construct-empty
+ browser-gadget new
dup init-history [
toolbar,
g <help-pane> g-> set-browser-gadget-pane
] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget )
- debugger construct-empty
+ debugger new
[
toolbar,
<restart-list> g-> set-debugger-restarts
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
- f deploy-gadget construct-boa [
+ f deploy-gadget boa [
dup <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] with-pane ;
: <inspector-gadget> ( -- gadget )
- inspector-gadget construct-empty
+ inspector-gadget new
[
toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
: <input-scroller> ( interactor -- scroller )
<scroller>
- input-scroller construct-empty
+ input-scroller new
[ set-gadget-delegate ] keep ;
M: input-scroller pref-dim*
TUPLE: stack-display ;
: <stack-display> ( -- gadget )
- stack-display construct-empty
+ stack-display new
g workspace-listener swap [
dup <toolbar> f track,
listener-gadget-stack [ stack. ]
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
- listener-gadget construct-empty dup init-listener
+ listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
: listener-help "ui-listener" help-window ;
TUPLE: profiler-gadget pane ;
: <profiler-gadget> ( -- gadget )
- profiler-gadget construct-empty
+ profiler-gadget new
[
toolbar,
<pane> g-> set-profiler-gadget-pane
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- live-search construct-empty
+ live-search new
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
- variables-gadget construct-empty
+ variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> f walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> gadget-children ?nth ;
-: make-node ( quot -- ) { } make node construct-boa , ; inline
+: make-node ( quot -- ) { } make node boa , ; inline
: traverse-to-path ( topath gadget -- )
dup not [
TUPLE: dimensions-not-equal ;
: dimensions-not-equal ( -- * )
- \ dimensions-not-equal construct-empty throw ;
+ \ dimensions-not-equal new throw ;
M: dimensions-not-equal summary drop "Dimensions do not match" ;
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
[ natural-sort ] bi@
- dimensioned construct-boa ;
+ dimensioned boa ;
: >dimensioned< ( d -- n top bot )
{ dimensioned-value dimensioned-top dimensioned-bot }
TUPLE: x-clipboard atom contents ;
: <x-clipboard> ( atom -- clipboard )
- "" x-clipboard construct-boa ;
+ "" x-clipboard boa ;
: selection-property ( -- n )
"org.factorcode.Factor.SELECTION" x-atom ;
TUPLE: server-error tag message ;
: server-error ( tag message -- * )
- \ server-error construct-boa throw ;
+ \ server-error boa throw ;
M: server-error error.
"Error in XML supplied to server" print
: run-process ( tag word -- )
2dup "xtable" word-prop
>r dup name-tag r> at* [ 2nip call ] [
- drop \ process-missing construct-boa throw
+ drop \ process-missing boa throw
] if ;
: PROCESS:
TAG: MODE
"NAME" over at >r
- mode construct-empty {
+ mode new {
{ "FILE" f set-mode-file }
{ "FILE_NAME_GLOB" f set-mode-file-name-glob }
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob }
} set-slots ;
: <rule-set> ( -- ruleset )
- rule-set construct-empty dup init-rule-set ;
+ rule-set new dup init-rule-set ;
MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ;
;
: construct-rule ( class -- rule )
- >r rule construct-empty r> construct-delegate ; inline
+ >r rule new r> construct-delegate ; inline
TUPLE: seq-rule ;
TUPLE: company employees type ;
-: <company> V{ } clone f company construct-boa ;
+: <company> V{ } clone f company boa ;
: add-employee company-employees push ;
TUPLE: employee name description ;
TAG: employee
- employee construct-empty
+ employee new
{ { "name" f set-employee-name } { f set-employee-description } }
init-from-tag swap add-employee ;
projects / factor.git / commitdiff