Doug Coleman
parent
30b75a797a
commit
72080fda4a
|
|
@ -21,7 +21,7 @@ SYMBOL: alarm-thread
|
|||
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*
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ SYMBOL: elements
|
|||
|
||||
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 ;
|
||||
|
|
@ -172,7 +172,7 @@ SYMBOL: tagnum
|
|||
|
||||
TUPLE: tag value ;
|
||||
|
||||
: <tag> ( -- <tag> ) 4 tag construct-boa ;
|
||||
: <tag> ( -- <tag> ) 4 tag boa ;
|
||||
|
||||
: with-ber ( quot -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: x30 g ;
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ INSTANCE: x30 g
|
|||
"benchmark.dispatch5" 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
|
||||
|
|
|
|||
|
|
@ -5,6 +5,6 @@ TUPLE: hello n ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -7,6 +7,6 @@ TUPLE: hello n ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -7,6 +7,6 @@ TUPLE: hello n ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -7,6 +7,6 @@ TUPLE: hello n ;
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: check< number bound ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: bubble-chamber.particle.axion
|
|||
|
||||
TUPLE: axion < particle ;
|
||||
|
||||
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
|
||||
: <axion> ( -- axion ) axion new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: bubble-chamber.particle.hadron
|
|||
|
||||
TUPLE: hadron < particle ;
|
||||
|
||||
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
|
||||
: <hadron> ( -- hadron ) hadron new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ IN: bubble-chamber.particle.muon
|
|||
|
||||
TUPLE: muon < particle ;
|
||||
|
||||
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
|
||||
: <muon> ( -- muon ) muon new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: bubble-chamber.particle.quark
|
|||
|
||||
TUPLE: quark < particle ;
|
||||
|
||||
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
|
||||
: <quark> ( -- quark ) quark new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
|
|||
|
||||
: <bunny-dlist> ( model -- geom )
|
||||
GL_COMPILE [ first3 draw-triangles ] make-dlist
|
||||
bunny-dlist construct-boa ;
|
||||
bunny-dlist boa ;
|
||||
|
||||
: <bunny-buffers> ( model -- geom )
|
||||
{
|
||||
|
|
@ -76,7 +76,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
|
|||
]
|
||||
[ first length 3 * ]
|
||||
[ third length 3 * ]
|
||||
} cleave bunny-buffers construct-boa ;
|
||||
} cleave bunny-buffers boa ;
|
||||
|
||||
GENERIC: bunny-geom ( geom -- )
|
||||
GENERIC: draw-bunny ( geom draw -- )
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ ERROR: cairo-error string ;
|
|||
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>
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: channels
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: circular
|
|||
TUPLE: circular seq start ;
|
||||
|
||||
: <circular> ( seq -- circular )
|
||||
0 circular construct-boa ;
|
||||
0 circular boa ;
|
||||
|
||||
: circular-wrap ( n circular -- n circular )
|
||||
[ start>> + ] keep
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ HELP: >tuple<
|
|||
{ $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." }
|
||||
|
|
@ -19,7 +19,7 @@ HELP: >tuple*<
|
|||
{ $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." }
|
||||
|
|
|
|||
|
|
@ -3,6 +3,6 @@ IN: classes.tuple.lib.tests
|
|||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ IN: cocoa.application
|
|||
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" ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
|
|||
|
||||
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? [
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ MACRO: map-exec-with ( words -- )
|
|||
[ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ TUPLE: count-down n promise ;
|
|||
|
||||
: <count-down> ( n -- count-down )
|
||||
dup 0 < [ "Invalid count for count down" throw ] when
|
||||
<promise> \ count-down construct-boa
|
||||
<promise> \ count-down boa
|
||||
dup count-down-check ;
|
||||
|
||||
: count-down ( count-down -- )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: concurrency.exchangers
|
|||
TUPLE: exchanger thread object ;
|
||||
|
||||
: <exchanger> ( -- exchanger )
|
||||
<box> <box> exchanger construct-boa ;
|
||||
<box> <box> exchanger boa ;
|
||||
|
||||
: exchange ( obj exchanger -- newobj )
|
||||
dup exchanger-thread box-full? [
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: concurrency.flags
|
|||
|
||||
TUPLE: flag value? thread ;
|
||||
|
||||
: <flag> ( -- flag ) f <box> flag construct-boa ;
|
||||
: <flag> ( -- flag ) f <box> flag boa ;
|
||||
|
||||
: raise-flag ( flag -- )
|
||||
dup flag-value? [
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@ IN: concurrency.locks
|
|||
TUPLE: lock threads owner reentrant? ;
|
||||
|
||||
: <lock> ( -- lock )
|
||||
<dlist> f f lock construct-boa ;
|
||||
<dlist> f f lock boa ;
|
||||
|
||||
: <reentrant-lock> ( -- lock )
|
||||
<dlist> f t lock construct-boa ;
|
||||
<dlist> f t lock boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -51,7 +51,7 @@ PRIVATE>
|
|||
TUPLE: rw-lock readers writers reader# writer ;
|
||||
|
||||
: <rw-lock> ( -- lock )
|
||||
<dlist> <dlist> 0 f rw-lock construct-boa ;
|
||||
<dlist> <dlist> 0 f rw-lock boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ M: mailbox dispose
|
|||
t >>closed threads>> notify-all ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
<dlist> <dlist> f mailbox construct-boa ;
|
||||
<dlist> <dlist> f mailbox boa ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
data>> dlist-empty? ;
|
||||
|
|
|
|||
|
|
@ -40,12 +40,12 @@ M: thread send ( message thread -- )
|
|||
TUPLE: synchronous data sender tag ;
|
||||
|
||||
: <synchronous> ( data -- sync )
|
||||
self 256 random-bits synchronous construct-boa ;
|
||||
self 256 random-bits synchronous boa ;
|
||||
|
||||
TUPLE: reply data tag ;
|
||||
|
||||
: <reply> ( data synchronous -- reply )
|
||||
synchronous-tag \ reply construct-boa ;
|
||||
synchronous-tag \ reply boa ;
|
||||
|
||||
: synchronous-reply? ( response synchronous -- ? )
|
||||
over reply?
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: concurrency.promises
|
|||
TUPLE: promise mailbox ;
|
||||
|
||||
: <promise> ( -- promise )
|
||||
<mailbox> promise construct-boa ;
|
||||
<mailbox> promise boa ;
|
||||
|
||||
: promise-fulfilled? ( promise -- ? )
|
||||
promise-mailbox mailbox-empty? not ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: semaphore count threads ;
|
|||
|
||||
: <semaphore> ( n -- semaphore )
|
||||
dup 0 < [ "Cannot have semaphore with negative count" throw ] when
|
||||
<dlist> semaphore construct-boa ;
|
||||
<dlist> semaphore boa ;
|
||||
|
||||
: wait-to-acquire ( semaphore timeout -- )
|
||||
>r semaphore-threads r> "semaphore" wait ;
|
||||
|
|
|
|||
|
|
@ -194,7 +194,7 @@ TUPLE: event-stream info handle closed ;
|
|||
>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 ] [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ SYMBOL: current-coro
|
|||
TUPLE: coroutine resumecc exitcc ;
|
||||
|
||||
: cocreate ( quot -- co )
|
||||
coroutine construct-empty
|
||||
coroutine new
|
||||
dup current-coro associate
|
||||
[ swapd , , \ bind ,
|
||||
"Coroutine has terminated illegally." , \ throw ,
|
||||
|
|
|
|||
|
|
@ -425,7 +425,7 @@ M: cpu reset ( cpu -- )
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ TUPLE: db
|
|||
delete-statements ;
|
||||
|
||||
: construct-db ( class -- obj )
|
||||
construct-empty
|
||||
new
|
||||
H{ } clone >>insert-statements
|
||||
H{ } clone >>update-statements
|
||||
H{ } clone >>delete-statements ;
|
||||
|
|
@ -52,7 +52,7 @@ TUPLE: throwable-statement < statement ;
|
|||
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 ;
|
||||
|
|
@ -96,7 +96,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
|
|||
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
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
|||
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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: destructors.tests
|
|||
|
||||
TUPLE: dummy-obj destroyed? ;
|
||||
|
||||
: <dummy-obj> dummy-obj construct-empty ;
|
||||
: <dummy-obj> dummy-obj new ;
|
||||
|
||||
TUPLE: dummy-destructor obj ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ M: destructor dispose
|
|||
] if ;
|
||||
|
||||
: <destructor> ( obj -- newobj )
|
||||
f destructor construct-boa ;
|
||||
f destructor boa ;
|
||||
|
||||
: add-error-destructor ( obj -- )
|
||||
<destructor> error-destructors get push ;
|
||||
|
|
|
|||
|
|
@ -7,10 +7,10 @@ TUPLE: digraph ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ PRIVATE>
|
|||
[ >array ]
|
||||
[ 0 <array> ]
|
||||
[ 1 <array> ] tri
|
||||
disjoint-set construct-boa ;
|
||||
disjoint-set boa ;
|
||||
|
||||
: equiv-set-size ( a disjoint-set -- n )
|
||||
[ representative ] keep count ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ SYMBOL: edit-hook
|
|||
[ [ "Load " prepend ] keep ] { } map>assoc ;
|
||||
|
||||
: no-edit-hook ( -- )
|
||||
\ no-edit-hook construct-empty
|
||||
\ no-edit-hook new
|
||||
editor-restarts throw-restarts
|
||||
require ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: gap-buffer.cursortree
|
|||
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 )
|
||||
|
|
@ -38,16 +38,16 @@ M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>in
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ M: gb set-gb-seq ( seq gb -- ) set-delegate ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ INSTANCE: word topic
|
|||
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? ;
|
||||
|
||||
|
|
@ -40,13 +40,13 @@ GENERIC: set-article-parent ( parent topic -- )
|
|||
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" ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: funky browser-link-href
|
|||
|
||||
[ "<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
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ TUPLE: html-stream last-div? ;
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ IN: http
|
|||
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 )
|
||||
|
|
@ -176,7 +176,7 @@ post-data-type
|
|||
cookies ;
|
||||
|
||||
: <request>
|
||||
request construct-empty
|
||||
request new
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>header
|
||||
|
|
@ -346,7 +346,7 @@ cookies
|
|||
body ;
|
||||
|
||||
: <response>
|
||||
response construct-empty
|
||||
response new
|
||||
"1.1" >>version
|
||||
H{ } clone >>header
|
||||
"close" "connection" set-header
|
||||
|
|
@ -434,7 +434,7 @@ message
|
|||
body ;
|
||||
|
||||
: <raw-response> ( -- response )
|
||||
raw-response construct-empty
|
||||
raw-response new
|
||||
"1.1" >>version ;
|
||||
|
||||
M: raw-response write-response ( respose -- )
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ SYMBOL: params
|
|||
TUPLE: action init display submit get-params post-params ;
|
||||
|
||||
: <action>
|
||||
action construct-empty
|
||||
action new
|
||||
[ ] >>init
|
||||
[ <400> ] >>display
|
||||
[ <400> ] >>submit ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ http.server.auth.providers ;
|
|||
TUPLE: users-in-memory assoc ;
|
||||
|
||||
: <users-in-memory> ( -- provider )
|
||||
H{ } clone users-in-memory construct-boa ;
|
||||
H{ } clone users-in-memory boa ;
|
||||
|
||||
M: users-in-memory get-user ( username provider -- user/f )
|
||||
assoc>> at ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: http.server.auth.providers
|
|||
|
||||
TUPLE: user username realname password email ticket profile ;
|
||||
|
||||
: <user> user construct-empty H{ } clone >>profile ;
|
||||
: <user> user new H{ } clone >>profile ;
|
||||
|
||||
GENERIC: get-user ( username provider -- user/f )
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: callback-responder responder callbacks ;
|
|||
#! A continuation responder is a special type of session
|
||||
#! manager. However it works entirely differently from
|
||||
#! the URL and cookie session managers.
|
||||
H{ } clone callback-responder construct-boa ;
|
||||
H{ } clone callback-responder boa ;
|
||||
|
||||
TUPLE: callback cont quot expires alarm responder ;
|
||||
|
||||
|
|
@ -32,7 +32,7 @@ TUPLE: callback cont quot expires alarm responder ;
|
|||
] when drop ;
|
||||
|
||||
: <callback> ( cont quot expires? -- callback )
|
||||
f callback-responder get callback construct-boa
|
||||
f callback-responder get callback boa
|
||||
dup touch-callback ;
|
||||
|
||||
: invoke-callback ( callback -- response )
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ validation-failed? off
|
|||
|
||||
TUPLE: test-tuple text number more-text ;
|
||||
|
||||
: <test-tuple> test-tuple construct-empty ;
|
||||
: <test-tuple> test-tuple new ;
|
||||
|
||||
: <test-form> ( -- form )
|
||||
"test" <form>
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ SYMBOL: values
|
|||
] if ;
|
||||
|
||||
: <component> ( id class -- component )
|
||||
\ component construct-empty
|
||||
\ component new
|
||||
swap construct-delegate
|
||||
swap >>id ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ SYMBOL: form-hook
|
|||
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 ;
|
||||
|
|
@ -131,7 +131,7 @@ M: dispatcher call-responder ( path dispatcher -- response )
|
|||
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*
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ M: object init-session* drop ;
|
|||
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? ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: http.server.sessions.storage.assoc
|
|||
TUPLE: sessions-in-memory sessions alarms ;
|
||||
|
||||
: <sessions-in-memory> ( -- storage )
|
||||
H{ } clone H{ } clone sessions-in-memory construct-boa ;
|
||||
H{ } clone H{ } clone sessions-in-memory boa ;
|
||||
|
||||
: cancel-session-timeout ( id storage -- )
|
||||
alarms>> at [ cancel-alarm ] when* ;
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ session "SESSIONS"
|
|||
: 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 )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ TUPLE: file-responder root hook special ;
|
|||
304 "Not modified" <trivial-response> ;
|
||||
|
||||
: <file-responder> ( root hook -- responder )
|
||||
H{ } clone file-responder construct-boa ;
|
||||
H{ } clone file-responder boa ;
|
||||
|
||||
: <static> ( root -- responder )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ C: <nil> nil
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ mirrors combinators.lib ;
|
|||
IN: inverse
|
||||
|
||||
TUPLE: fail ;
|
||||
: fail ( -- * ) \ fail construct-empty throw ;
|
||||
: fail ( -- * ) \ fail new throw ;
|
||||
M: fail summary drop "Unification failed" ;
|
||||
|
||||
: assure ( ? -- ) [ fail ] unless ;
|
||||
|
|
@ -26,7 +26,7 @@ M: fail summary drop "Unification failed" ;
|
|||
"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" ;
|
||||
|
||||
|
|
@ -214,14 +214,14 @@ DEFER: _
|
|||
: 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
|
||||
|
|
@ -255,7 +255,7 @@ DEFER: _
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ accessors ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ M: 8-bit decode-char
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ TUPLE: strict code ;
|
|||
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" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ SYMBOL: +highest-priority+
|
|||
SYMBOL: +realtime-priority+
|
||||
|
||||
: <process> ( -- process )
|
||||
process construct-empty
|
||||
process new
|
||||
H{ } clone >>environment
|
||||
+append-environment+ >>environment-mode ;
|
||||
|
||||
|
|
@ -130,7 +130,7 @@ HOOK: run-process* io-backend ( process -- handle )
|
|||
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?
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ M: monitor timeout timeout>> ;
|
|||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: construct-monitor ( path mailbox class -- monitor )
|
||||
construct-empty
|
||||
new
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -30,8 +30,8 @@ M: mock-io-backend (monitor)
|
|||
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 [
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ GENERIC: init-handle ( handle -- )
|
|||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle class -- port )
|
||||
construct-empty
|
||||
new
|
||||
swap dup init-handle >>handle ; inline
|
||||
|
||||
: <buffered-port> ( handle class -- port )
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ;
|
|||
] 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 )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: io.sockets
|
|||
TUPLE: local path ;
|
||||
|
||||
: <local> ( path -- addrspec )
|
||||
normalize-path local construct-boa ;
|
||||
normalize-path local boa ;
|
||||
|
||||
TUPLE: inet4 host port ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: io-task port callbacks ;
|
|||
: io-task-fd port>> handle>> ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
construct-empty
|
||||
new
|
||||
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
|
||||
swap >>port ; inline
|
||||
|
||||
|
|
@ -33,7 +33,7 @@ M: input-task io-task-container drop reads>> ;
|
|||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: construct-mx ( class -- obj )
|
||||
construct-empty
|
||||
new
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ M: unix copy-file ( from to -- )
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: io.unix.mmap
|
|||
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
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
|||
[ 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> [
|
||||
|
|
@ -69,7 +69,7 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
|||
[ 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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ TUPLE: CreateProcess-args
|
|||
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
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ M: windows <mapped-file> ( path length -- mmap )
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ TUPLE: pipe in out ;
|
|||
[
|
||||
>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 -- )
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ TUPLE: ConnectEx-args port
|
|||
|
||||
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
|
||||
|
|
@ -123,7 +123,7 @@ M: winnt (accept) ( server -- addrspec handle )
|
|||
[
|
||||
[
|
||||
check-server-port
|
||||
\ AcceptEx-args construct-empty
|
||||
\ AcceptEx-args new
|
||||
[ init-accept ] keep
|
||||
[ ((accept)) ] keep
|
||||
[ accept-continuation ] keep
|
||||
|
|
@ -193,7 +193,7 @@ TUPLE: WSARecvFrom-args port
|
|||
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
|
||||
|
|
@ -245,7 +245,7 @@ USE: io.sockets
|
|||
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
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@ HOOK: WSASocket-flags io-backend ( -- DWORD )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -39,14 +39,14 @@ TUPLE: irc-client profile nick stream stream-channel controller-channel
|
|||
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 ] ]
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: jamshred tunnel players running ;
|
|||
|
||||
: <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
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: jamshred.oint
|
|||
TUPLE: oint location forward up left ;
|
||||
|
||||
: <oint> ( location forward up left -- oint )
|
||||
oint construct-boa ;
|
||||
oint boa ;
|
||||
|
||||
! : x-rotation ( theta -- matrix )
|
||||
! #! construct this matrix:
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: jamshred.player
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: jamshred.tunnel
|
|||
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
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool )
|
|||
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 ;
|
||||
|
||||
|
|
@ -103,7 +103,7 @@ TUPLE: memoized-cons original car cdr nil? ;
|
|||
|
||||
: <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? [
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ TUPLE: erato limit bits latest ;
|
|||
[ [ 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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ TUPLE: range from length step ;
|
|||
: <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 ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ tools.test ;
|
|||
|
||||
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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: model < identity-tuple
|
|||
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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ MACRO: set-draw-buffers ( buffers -- )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ M: comment pprint*
|
|||
swap comment-node present-text ;
|
||||
|
||||
: comment, ( ? node text -- )
|
||||
rot [ \ comment construct-boa , ] [ 2drop ] if ;
|
||||
rot [ \ comment boa , ] [ 2drop ] if ;
|
||||
|
||||
: values% ( prefix values -- )
|
||||
swap [
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ M: fail-parser parse ( input parser -- list )
|
|||
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?
|
||||
|
|
@ -122,7 +122,7 @@ M: ensure-parser parse ( input parser -- list )
|
|||
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?
|
||||
|
|
@ -135,10 +135,10 @@ TUPLE: and-parser parsers ;
|
|||
>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 [
|
||||
|
|
@ -161,7 +161,7 @@ M: and-parser parse ( input parser -- list )
|
|||
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> ;
|
||||
|
|
@ -265,7 +265,7 @@ LAZY: <?> ( parser -- 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
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ M: just-parser (compile) ( parser -- quot )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ C: <parser> parser
|
|||
SYMBOL: ignore
|
||||
|
||||
: <parse-result> ( remaining ast -- parse-result )
|
||||
parse-result construct-boa ;
|
||||
parse-result boa ;
|
||||
|
||||
SYMBOL: packrat
|
||||
SYMBOL: pos
|
||||
|
|
@ -468,16 +468,16 @@ M: box-parser (compile) ( parser -- quot )
|
|||
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 ;
|
||||
|
|
@ -492,7 +492,7 @@ PRIVATE>
|
|||
{ } make seq ; inline
|
||||
|
||||
: choice ( seq -- parser )
|
||||
choice-parser construct-boa init-parser ;
|
||||
choice-parser boa init-parser ;
|
||||
|
||||
: 2choice ( parser1 parser2 -- parser )
|
||||
2array choice ;
|
||||
|
|
@ -507,34 +507,34 @@ PRIVATE>
|
|||
{ } 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
|
||||
|
|
@ -548,7 +548,7 @@ PRIVATE>
|
|||
#! 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:
|
||||
(:) [
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: processing-gadget button-down button-up key-down key-up ;
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: <processing-gadget> ( -- gadget )
|
||||
processing-gadget construct-empty
|
||||
processing-gadget new
|
||||
<frame-buffer> set-gadget-delegate ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: promises
|
|||
TUPLE: promise quot forced? value ;
|
||||
|
||||
: promise ( quot -- promise )
|
||||
f f \ promise construct-boa ;
|
||||
f f \ promise boa ;
|
||||
|
||||
: promise-with ( value quot -- promise )
|
||||
curry promise ;
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ TUPLE: blum-blum-shub x n ;
|
|||
: <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
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ TUPLE: mersenne-twister seq i ;
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -269,7 +269,7 @@ TUPLE: regexp source parser ignore-case? ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ TUPLE: roman-range-error n ;
|
|||
dup 1 3999 between? [
|
||||
drop
|
||||
] [
|
||||
roman-range-error construct-boa throw
|
||||
roman-range-error boa throw
|
||||
] if ;
|
||||
|
||||
: roman<= ( ch1 ch2 -- ? )
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@ IN: semantic-db
|
|||
|
||||
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"
|
||||
{
|
||||
|
|
@ -34,10 +34,10 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -277,7 +277,7 @@ SYMBOL: deserialized
|
|||
: deserialize-tuple ( -- array )
|
||||
#! Ugly because we have to intern the tuple before reading
|
||||
#! slots
|
||||
(deserialize) construct-empty
|
||||
(deserialize) new
|
||||
[ intern-object ]
|
||||
[
|
||||
[ (deserialize) ]
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue