Doug Coleman
parent
6b6af27dfa
commit
30b75a797a
|
|
@ -54,7 +54,7 @@ TUPLE: library path abi dll ;
|
|||
: library ( name -- library ) libraries get at ;
|
||||
|
||||
: <library> ( path abi -- library )
|
||||
over dup [ dlopen ] when \ library construct-boa ;
|
||||
over dup [ dlopen ] when \ library boa ;
|
||||
|
||||
: load-library ( name -- dll )
|
||||
library dup [ library-dll ] when ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ getter setter
|
|||
reg-class size align stack-align? ;
|
||||
|
||||
: construct-c-type ( class -- type )
|
||||
construct-empty
|
||||
new
|
||||
int-regs >>reg-class ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ M: no-such-library compiler-error-type
|
|||
drop +linkage+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library construct-boa
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
|
@ -232,7 +232,7 @@ M: no-such-symbol compiler-error-type
|
|||
drop +linkage+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol construct-boa
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
|
|
@ -251,7 +251,7 @@ M: no-such-symbol compiler-error-type
|
|||
\ alien-invoke [
|
||||
! Four literals
|
||||
4 ensure-values
|
||||
#alien-invoke construct-empty
|
||||
#alien-invoke new
|
||||
! Compile-time parameters
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>function
|
||||
|
|
@ -288,7 +288,7 @@ M: alien-indirect-error summary
|
|||
! Three literals and function pointer
|
||||
4 ensure-values
|
||||
4 reify-curries
|
||||
#alien-indirect construct-empty
|
||||
#alien-indirect new
|
||||
! Compile-time parameters
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
|
|
@ -335,7 +335,7 @@ M: alien-callback-error summary
|
|||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
#alien-callback construct-empty dup node,
|
||||
#alien-callback new dup node,
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
|
|
@ -381,7 +381,7 @@ TUPLE: callback-context ;
|
|||
: wrap-callback-quot ( node -- quot )
|
||||
[
|
||||
[ quot>> ] [ prepare-callback-return ] bi append ,
|
||||
[ callback-context construct-empty do-callback ] %
|
||||
[ callback-context new do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: struct-type stack-size
|
|||
|
||||
: (define-struct) ( name vocab size align fields -- )
|
||||
>r [ align ] keep r>
|
||||
struct-type construct-boa
|
||||
struct-type boa
|
||||
-rot define-c-type ;
|
||||
|
||||
: make-field ( struct-name vocab type field-name -- spec )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: bit-vectors
|
|||
<PRIVATE
|
||||
|
||||
: bit-array>vector ( bit-array length -- bit-vector )
|
||||
bit-vector construct-boa ; inline
|
||||
bit-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: boxes
|
|||
|
||||
TUPLE: box value full? ;
|
||||
|
||||
: <box> ( -- box ) box construct-empty ;
|
||||
: <box> ( -- box ) box new ;
|
||||
|
||||
: >box ( value box -- )
|
||||
dup box-full? [ "Box already has a value" throw ] when
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: byte-vectors
|
|||
<PRIVATE
|
||||
|
||||
: byte-array>vector ( byte-array length -- byte-vector )
|
||||
byte-vector construct-boa ; inline
|
||||
byte-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ;
|
|||
|
||||
: check-mixin-class ( mixin -- mixin )
|
||||
dup mixin-class? [
|
||||
\ check-mixin-class construct-boa throw
|
||||
\ check-mixin-class boa throw
|
||||
] unless ;
|
||||
|
||||
: if-mixin-member? ( class mixin true false -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ generic.standard sequences definitions compiler.units ;
|
|||
IN: classes.tuple
|
||||
|
||||
ARTICLE: "parametrized-constructors" "Parameterized constructors"
|
||||
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
||||
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
||||
$nl
|
||||
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
|
||||
{ $code
|
||||
|
|
@ -14,14 +14,14 @@ $nl
|
|||
""
|
||||
"TUPLE: car < vehicle engine ;"
|
||||
": <car> ( max-speed engine -- car )"
|
||||
" car construct-empty"
|
||||
" car new"
|
||||
" V{ } clone >>occupants"
|
||||
" swap >>engine"
|
||||
" swap >>max-speed ;"
|
||||
""
|
||||
"TUPLE: aeroplane < vehicle max-altitude ;"
|
||||
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
|
||||
" aeroplane construct-empty"
|
||||
" aeroplane new"
|
||||
" V{ } clone >>occupants"
|
||||
" swap >>max-altitude"
|
||||
" swap >>max-speed ;"
|
||||
|
|
@ -33,7 +33,7 @@ $nl
|
|||
": add-occupant ( person vehicle -- ) occupants>> push ;"
|
||||
""
|
||||
": construct-vehicle ( class -- vehicle )"
|
||||
" construct-empty"
|
||||
" new"
|
||||
" V{ } clone >>occupants ;"
|
||||
""
|
||||
"TUPLE: car < vehicle engine ;"
|
||||
|
|
@ -52,8 +52,8 @@ $nl
|
|||
|
||||
ARTICLE: "tuple-constructors" "Tuple constructors"
|
||||
"Tuples are created by calling one of two constructor primitives:"
|
||||
{ $subsection construct-empty }
|
||||
{ $subsection construct-boa }
|
||||
{ $subsection new }
|
||||
{ $subsection boa }
|
||||
"A shortcut for defining BOA constructors:"
|
||||
{ $subsection POSTPONE: C: }
|
||||
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
|
||||
|
|
@ -65,11 +65,11 @@ $nl
|
|||
"TUPLE: color red green blue alpha ;"
|
||||
""
|
||||
"C: <rgba> rgba"
|
||||
": <rgba> color construct-boa ; ! identical to above"
|
||||
": <rgba> color boa ; ! identical to above"
|
||||
""
|
||||
": <rgb> f <rgba> ;"
|
||||
""
|
||||
": <color> construct-empty ;"
|
||||
": <color> new ;"
|
||||
": <color> f f f f <rgba> ; ! identical to above"
|
||||
}
|
||||
{ $subsection "parametrized-constructors" } ;
|
||||
|
|
@ -129,7 +129,7 @@ $nl
|
|||
$nl
|
||||
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
|
||||
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
|
||||
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
|
||||
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
|
||||
{ $see-also "parametrized-constructors" } ;
|
||||
|
||||
ARTICLE: "tuple-subclassing" "Tuple subclassing"
|
||||
|
|
@ -164,11 +164,11 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
}
|
||||
"We can define a constructor which makes an empty employee:"
|
||||
{ $code ": <employee> ( -- employee )"
|
||||
" employee construct-empty ;" }
|
||||
" employee new ;" }
|
||||
"Or we may wish the default constructor to always give employees a starting salary:"
|
||||
{ $code
|
||||
": <employee> ( -- employee )"
|
||||
" employee construct-empty"
|
||||
" employee new"
|
||||
" 40000 >>salary ;"
|
||||
}
|
||||
"We can define more refined constructors:"
|
||||
|
|
@ -178,7 +178,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
"An alternative strategy is to define the most general BOA constructor first:"
|
||||
{ $code
|
||||
": <employee> ( name position -- person )"
|
||||
" 40000 employee construct-boa ;"
|
||||
" 40000 employee boa ;"
|
||||
}
|
||||
"Now we can define more specific constructors:"
|
||||
{ $code
|
||||
|
|
@ -191,7 +191,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
"SYMBOL: checks"
|
||||
""
|
||||
": <check> ( to amount -- check )"
|
||||
" checks counter check construct-boa ;"
|
||||
" checks counter check boa ;"
|
||||
""
|
||||
": biweekly-paycheck ( employee -- check )"
|
||||
" dup name>> swap salary>> 26 / <check> ;"
|
||||
|
|
@ -326,20 +326,20 @@ HELP: tuple>array ( tuple -- array )
|
|||
|
||||
HELP: <tuple> ( layout -- tuple )
|
||||
{ $values { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
|
||||
|
||||
HELP: <tuple-boa> ( ... layout -- tuple )
|
||||
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
|
||||
|
||||
HELP: construct-empty
|
||||
HELP: new
|
||||
{ $values { "class" tuple-class } { "tuple" tuple } }
|
||||
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel prettyprint ;"
|
||||
"TUPLE: employee number name department ;"
|
||||
"employee construct-empty ."
|
||||
"employee new ."
|
||||
"T{ employee f f f f }"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -361,12 +361,12 @@ HELP: construct
|
|||
" color construct ;"
|
||||
}
|
||||
"The last definition is actually equivalent to the following:"
|
||||
{ $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
|
||||
{ $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
|
||||
"Which can be abbreviated further:"
|
||||
{ $code "C: <rgba> color" }
|
||||
} ;
|
||||
|
||||
HELP: construct-boa
|
||||
HELP: boa
|
||||
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
||||
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
||||
{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
|
||||
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ;
|
|||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
: <rect> rect construct-boa ;
|
||||
: <rect> rect boa ;
|
||||
|
||||
: move ( x rect -- rect )
|
||||
[ + ] change-x ;
|
||||
|
|
@ -198,8 +198,8 @@ SYMBOL: not-a-tuple-class
|
|||
] unit-test
|
||||
|
||||
! Missing check
|
||||
[ not-a-tuple-class construct-boa ] must-fail
|
||||
[ not-a-tuple-class construct-empty ] must-fail
|
||||
[ not-a-tuple-class boa ] must-fail
|
||||
[ not-a-tuple-class new ] must-fail
|
||||
|
||||
TUPLE: erg's-reshape-problem a b c d ;
|
||||
|
||||
|
|
@ -207,8 +207,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
|
||||
! We want to make sure constructors are recompiled when
|
||||
! tuples are reshaped
|
||||
: cons-test-1 \ erg's-reshape-problem construct-empty ;
|
||||
: cons-test-2 \ erg's-reshape-problem construct-boa ;
|
||||
: cons-test-1 \ erg's-reshape-problem new ;
|
||||
: cons-test-2 \ erg's-reshape-problem boa ;
|
||||
|
||||
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
||||
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@ M: tuple-class define-tuple-class
|
|||
|
||||
: define-error-class ( class superclass slots -- )
|
||||
[ define-tuple-class ] [ 2drop ] 3bi
|
||||
dup [ construct-boa throw ] curry define ;
|
||||
dup [ boa throw ] curry define ;
|
||||
|
||||
M: tuple-class reset-class
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ;
|
|||
TUPLE: color red green blue ;
|
||||
|
||||
[ T{ color f 1 2 3 } ]
|
||||
[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
|
||||
[ 1 2 3 [ color boa ] compile-call ] unit-test
|
||||
|
||||
[ 1 3 ] [
|
||||
1 2 3 color construct-boa
|
||||
1 2 3 color boa
|
||||
[ { color-red color-blue } get-slots ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ T{ color f 10 2 20 } ] [
|
||||
10 20
|
||||
1 2 3 color construct-boa [
|
||||
1 2 3 color boa [
|
||||
[
|
||||
{ set-color-red set-color-blue } set-slots
|
||||
] compile-call
|
||||
|
|
@ -21,4 +21,4 @@ TUPLE: color red green blue ;
|
|||
] unit-test
|
||||
|
||||
[ T{ color f f f f } ]
|
||||
[ [ color construct-empty ] compile-call ] unit-test
|
||||
[ [ color new ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: new-definitions
|
|||
TUPLE: redefine-error def ;
|
||||
|
||||
: redefine-error ( definition -- )
|
||||
\ redefine-error construct-boa
|
||||
\ redefine-error boa
|
||||
{ { "Continue" t } } throw-restarts drop ;
|
||||
|
||||
: add-once ( key assoc -- )
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ;
|
|||
canonicalize-ESP ;
|
||||
|
||||
: <indirect> ( base index scale displacement -- indirect )
|
||||
indirect construct-boa dup canonicalize ;
|
||||
indirect boa dup canonicalize ;
|
||||
|
||||
: reg-code "register" word-prop 7 bitand ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: dlists
|
|||
TUPLE: dlist front back length ;
|
||||
|
||||
: <dlist> ( -- obj )
|
||||
dlist construct-empty
|
||||
dlist new
|
||||
0 >>length ;
|
||||
|
||||
: dlist-empty? ( dlist -- ? ) front>> not ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ;
|
|||
|
||||
: <effect> ( in out -- effect )
|
||||
dup { "*" } sequence= [ drop { } t ] [ f ] if
|
||||
effect construct-boa ;
|
||||
effect boa ;
|
||||
|
||||
: effect-height ( effect -- n )
|
||||
dup effect-out length swap effect-in length - ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: float-vectors
|
|||
<PRIVATE
|
||||
|
||||
: float-array>vector ( float-array length -- float-vector )
|
||||
float-vector construct-boa ; inline
|
||||
float-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: generator.fixup
|
|||
|
||||
TUPLE: frame-required n ;
|
||||
|
||||
: frame-required ( n -- ) \ frame-required construct-boa , ;
|
||||
: frame-required ( n -- ) \ frame-required boa , ;
|
||||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
|
|
@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size )
|
|||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label construct-empty ;
|
||||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset swap set-label-offset ;
|
||||
|
|
@ -74,7 +74,7 @@ SYMBOL: label-table
|
|||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup label-fixup-class rc-absolute?
|
||||
|
|
@ -84,7 +84,7 @@ M: label-fixup fixup*
|
|||
|
||||
TUPLE: rel-fixup arg class type ;
|
||||
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: (rel-fixup) ( arg class type offset -- pair )
|
||||
pick rc-absolute-cell = cell 4 ? -
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ INSTANCE: temp-reg value
|
|||
! A data stack location.
|
||||
TUPLE: ds-loc n class ;
|
||||
|
||||
: <ds-loc> f ds-loc construct-boa ;
|
||||
: <ds-loc> f ds-loc boa ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: ds-loc operand-class* ds-loc-class ;
|
||||
|
|
@ -87,7 +87,7 @@ M: ds-loc live-loc?
|
|||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
||||
: <rs-loc> f rs-loc construct-boa ;
|
||||
: <rs-loc> f rs-loc boa ;
|
||||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
|
|
@ -128,7 +128,7 @@ INSTANCE: cached value
|
|||
TUPLE: tagged vreg class ;
|
||||
|
||||
: <tagged> ( vreg -- tagged )
|
||||
f tagged construct-boa ;
|
||||
f tagged boa ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
|
|
@ -238,7 +238,7 @@ M: phantom-stack clone
|
|||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: construct-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> construct-boa ; inline
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc)
|
||||
#! Utility for methods on <loc>
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ TUPLE: check-method class generic ;
|
|||
|
||||
: check-method ( class generic -- class generic )
|
||||
over class? over generic? and [
|
||||
\ check-method construct-boa throw
|
||||
\ check-method boa throw
|
||||
] unless ; inline
|
||||
|
||||
: with-methods ( generic quot -- )
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ TUPLE: tuple-dispatch-engine echelons ;
|
|||
dupd <echelon-dispatch-engine>
|
||||
] if
|
||||
] assoc-map [ nip ] assoc-subset
|
||||
\ tuple-dispatch-engine construct-boa ;
|
||||
\ tuple-dispatch-engine boa ;
|
||||
|
||||
: convert-tuple-methods ( assoc -- assoc' )
|
||||
tuple bootstrap-word
|
||||
|
|
|
|||
|
|
@ -183,22 +183,22 @@ M: ceo salary
|
|||
|
||||
[ salary ] must-infer
|
||||
|
||||
[ 24000 ] [ employee construct-boa salary ] unit-test
|
||||
[ 24000 ] [ employee boa salary ] unit-test
|
||||
|
||||
[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
|
||||
[ 24000 ] [ tape-monkey boa salary ] unit-test
|
||||
|
||||
[ 36000 ] [ junior-manager construct-boa salary ] unit-test
|
||||
[ 36000 ] [ junior-manager boa salary ] unit-test
|
||||
|
||||
[ 41000 ] [ middle-manager construct-boa salary ] unit-test
|
||||
[ 41000 ] [ middle-manager boa salary ] unit-test
|
||||
|
||||
[ 51000 ] [ senior-manager construct-boa salary ] unit-test
|
||||
[ 51000 ] [ senior-manager boa salary ] unit-test
|
||||
|
||||
[ 102000 ] [ executive construct-boa salary ] unit-test
|
||||
[ 102000 ] [ executive boa salary ] unit-test
|
||||
|
||||
[ ceo construct-boa salary ]
|
||||
[ ceo boa salary ]
|
||||
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
|
||||
|
||||
[ intern construct-boa salary ]
|
||||
[ intern boa salary ]
|
||||
[ T{ no-next-method f intern salary } = ] must-fail-with
|
||||
|
||||
! Weird shit
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ IN: hashtables
|
|||
PRIVATE>
|
||||
|
||||
: <hashtable> ( n -- hash )
|
||||
hashtable construct-empty [ reset-hash ] keep ;
|
||||
hashtable new [ reset-hash ] keep ;
|
||||
|
||||
M: hashtable at* ( key hash -- value ? )
|
||||
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ GENERIC: heap-size ( heap -- n )
|
|||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone r> construct-boa ; inline
|
||||
>r V{ } clone r> boa ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key heap -- entry ) f entry construct-boa ;
|
||||
: <entry> ( value key heap -- entry ) f entry boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -39,9 +39,9 @@ M: inference-error compiler-error-type type>> ;
|
|||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
>r construct-boa r>
|
||||
>r boa r>
|
||||
recursive-state get
|
||||
\ inference-error construct-boa throw ; inline
|
||||
\ inference-error boa throw ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+error+ (inference-error) ; inline
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: inference.dataflow
|
|||
TUPLE: value < identity-tuple literal uid recursion ;
|
||||
|
||||
: <value> ( obj -- value )
|
||||
<computed> recursive-state get value construct-boa ;
|
||||
<computed> recursive-state get value boa ;
|
||||
|
||||
M: value hashcode* nip value-uid ;
|
||||
|
||||
|
|
@ -68,16 +68,16 @@ M: object flatten-curry , ;
|
|||
[ in-d>> ] [ out-d>> ] bi <effect> ;
|
||||
|
||||
: param-node ( param class -- node )
|
||||
construct-empty swap >>param ; inline
|
||||
new swap >>param ; inline
|
||||
|
||||
: in-node ( seq class -- node )
|
||||
construct-empty swap >>in-d ; inline
|
||||
new swap >>in-d ; inline
|
||||
|
||||
: all-in-node ( class -- node )
|
||||
flatten-meta-d swap in-node ; inline
|
||||
|
||||
: out-node ( seq class -- node )
|
||||
construct-empty swap >>out-d ; inline
|
||||
new swap >>out-d ; inline
|
||||
|
||||
: all-out-node ( class -- node )
|
||||
flatten-meta-d swap out-node ; inline
|
||||
|
|
@ -111,19 +111,19 @@ TUPLE: #call-label < node ;
|
|||
|
||||
TUPLE: #push < node ;
|
||||
|
||||
: #push ( -- node ) \ #push construct-empty ;
|
||||
: #push ( -- node ) \ #push new ;
|
||||
|
||||
TUPLE: #shuffle < node ;
|
||||
|
||||
: #shuffle ( -- node ) \ #shuffle construct-empty ;
|
||||
: #shuffle ( -- node ) \ #shuffle new ;
|
||||
|
||||
TUPLE: #>r < node ;
|
||||
|
||||
: #>r ( -- node ) \ #>r construct-empty ;
|
||||
: #>r ( -- node ) \ #>r new ;
|
||||
|
||||
TUPLE: #r> < node ;
|
||||
|
||||
: #r> ( -- node ) \ #r> construct-empty ;
|
||||
: #r> ( -- node ) \ #r> new ;
|
||||
|
||||
TUPLE: #values < node ;
|
||||
|
||||
|
|
@ -150,7 +150,7 @@ TUPLE: #merge < node ;
|
|||
|
||||
TUPLE: #terminate < node ;
|
||||
|
||||
: #terminate ( -- node ) \ #terminate construct-empty ;
|
||||
: #terminate ( -- node ) \ #terminate new ;
|
||||
|
||||
TUPLE: #declare < node ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ classes ;
|
|||
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||
|
||||
\ construct-empty must-infer
|
||||
\ new must-infer
|
||||
|
||||
TUPLE: a-tuple x y z ;
|
||||
|
||||
|
|
|
|||
|
|
@ -82,12 +82,12 @@ M: duplicated-slots-error summary
|
|||
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-boa [
|
||||
\ boa [
|
||||
dup +inlined+ depends-on
|
||||
tuple-layout [ <tuple-boa> ] curry
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-empty [
|
||||
\ new [
|
||||
1 ensure-values
|
||||
peek-d value? [
|
||||
pop-literal
|
||||
|
|
@ -95,7 +95,7 @@ M: duplicated-slots-error summary
|
|||
tuple-layout [ <tuple> ] curry
|
||||
swap infer-quot
|
||||
] [
|
||||
\ construct-empty 1 1 <effect> make-call-node
|
||||
\ new 1 1 <effect> make-call-node
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -30,8 +30,8 @@ ERROR: encode-error ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
M: tuple-class <decoder> construct-empty <decoder> ;
|
||||
M: tuple <decoder> f decoder construct-boa ;
|
||||
M: tuple-class <decoder> new <decoder> ;
|
||||
M: tuple <decoder> f decoder boa ;
|
||||
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
|
@ -104,8 +104,8 @@ M: decoder stream-readln ( stream -- str )
|
|||
M: decoder dispose decoder-stream dispose ;
|
||||
|
||||
! Encoding
|
||||
M: tuple-class <encoder> construct-empty <encoder> ;
|
||||
M: tuple <encoder> encoder construct-boa ;
|
||||
M: tuple-class <encoder> new <encoder> ;
|
||||
M: tuple <encoder> encoder boa ;
|
||||
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: io.streams.duplex.tests
|
|||
! Test duplex stream close behavior
|
||||
TUPLE: closing-stream closed? ;
|
||||
|
||||
: <closing-stream> closing-stream construct-empty ;
|
||||
: <closing-stream> closing-stream new ;
|
||||
|
||||
M: closing-stream dispose
|
||||
dup closing-stream-closed? [
|
||||
|
|
@ -15,7 +15,7 @@ M: closing-stream dispose
|
|||
|
||||
TUPLE: unclosable-stream ;
|
||||
|
||||
: <unclosable-stream> unclosable-stream construct-empty ;
|
||||
: <unclosable-stream> unclosable-stream new ;
|
||||
|
||||
M: unclosable-stream dispose
|
||||
"Can't close me!" throw ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: io.streams.duplex
|
|||
TUPLE: duplex-stream in out closed ;
|
||||
|
||||
: <duplex-stream> ( in out -- stream )
|
||||
f duplex-stream construct-boa ;
|
||||
f duplex-stream boa ;
|
||||
|
||||
ERROR: stream-closed-twice ;
|
||||
|
||||
|
|
|
|||
|
|
@ -142,10 +142,10 @@ M: object clone ;
|
|||
M: callstack clone (clone) ;
|
||||
|
||||
! Tuple construction
|
||||
: construct-empty ( class -- tuple )
|
||||
: new ( class -- tuple )
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
: construct-boa ( ... class -- tuple )
|
||||
: boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
||||
! Quotation building
|
||||
|
|
@ -203,7 +203,7 @@ GENERIC# get-slots 1 ( tuple slots -- ... )
|
|||
GENERIC# set-slots 1 ( ... tuple slots -- )
|
||||
|
||||
: construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ; inline
|
||||
new [ swap set-slots ] keep ; inline
|
||||
|
||||
: construct-delegate ( delegate class -- tuple )
|
||||
>r { set-delegate } r> construct ; inline
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: mirrors
|
|||
TUPLE: mirror object slots ;
|
||||
|
||||
: <mirror> ( object -- mirror )
|
||||
dup object-slots mirror construct-boa ;
|
||||
dup object-slots mirror boa ;
|
||||
|
||||
: >mirror< ( mirror -- obj slots )
|
||||
dup mirror-object swap mirror-slots ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ sequences.private combinators ;
|
|||
] "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
\ construct-empty [
|
||||
\ new [
|
||||
dup node-in-d peek node-literal
|
||||
dup class? [ drop tuple ] unless 1array f
|
||||
] "output-classes" set-word-prop
|
||||
|
|
|
|||
|
|
@ -283,7 +283,7 @@ TUPLE: silly-tuple a b ;
|
|||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
[ ] [ [ new ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ name>char-hook global [
|
|||
TUPLE: parse-error file line column line-text error ;
|
||||
|
||||
: <parse-error> ( msg -- error )
|
||||
\ parse-error construct-empty
|
||||
\ parse-error new
|
||||
file get >>file
|
||||
lexer get line>> >>line
|
||||
lexer get column>> >>column
|
||||
|
|
@ -256,7 +256,7 @@ M: no-word-error summary
|
|||
drop "Word not found in current vocabulary search path" ;
|
||||
|
||||
: no-word ( name -- newword )
|
||||
dup no-word-error construct-boa
|
||||
dup no-word-error boa
|
||||
swap words-named [ forward-reference? not ] subset
|
||||
word-restarts throw-restarts
|
||||
dup word-vocabulary (use+) ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ SYMBOL: pprinter-use
|
|||
|
||||
TUPLE: pprinter last-newline line-count end-printing indent ;
|
||||
|
||||
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
|
||||
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
|
||||
|
||||
: record-vocab ( word -- )
|
||||
word-vocabulary [ dup pprinter-use get set-at ] when* ;
|
||||
|
|
@ -72,7 +72,7 @@ start-group? end-group?
|
|||
style overhang ;
|
||||
|
||||
: construct-section ( length class -- section )
|
||||
construct-empty
|
||||
new
|
||||
position get >>start
|
||||
swap position [ + ] change
|
||||
position get >>end
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: sbufs
|
|||
<PRIVATE
|
||||
|
||||
: string>sbuf ( string length -- sbuf )
|
||||
sbuf construct-boa ; inline
|
||||
sbuf boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -197,7 +197,7 @@ ERROR: slice-error reason ;
|
|||
: <slice> ( from to seq -- slice )
|
||||
dup slice? [ collapse-slice ] when
|
||||
check-slice
|
||||
slice construct-boa ; inline
|
||||
slice boa ; inline
|
||||
|
||||
M: slice virtual-seq slice-seq ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: groups seq n sliced? ;
|
|||
: check-groups 0 <= [ "Invalid group count" throw ] when ;
|
||||
|
||||
: <groups> ( seq n -- groups )
|
||||
dup check-groups f groups construct-boa ; inline
|
||||
dup check-groups f groups boa ; inline
|
||||
|
||||
: <sliced-groups> ( seq n -- groups )
|
||||
<groups> t over set-groups-sliced? ;
|
||||
|
|
|
|||
|
|
@ -573,21 +573,21 @@ HELP: ERROR:
|
|||
""
|
||||
"TUPLE: invalid-values x y ;"
|
||||
": invalid-values ( x y -- * )"
|
||||
" \\ invalid-values construct-boa throw ;"
|
||||
" \\ invalid-values boa throw ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: C:
|
||||
{ $syntax "C: constructor class" }
|
||||
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
|
||||
{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link construct-boa } "." }
|
||||
{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link boa } "." }
|
||||
{ $examples
|
||||
"Suppose the following tuple has been defined:"
|
||||
{ $code "TUPLE: color red green blue ;" }
|
||||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"C: <color> color"
|
||||
": <color> color construct-boa ;"
|
||||
": <color> color boa ;"
|
||||
}
|
||||
"In both cases, a word " { $snippet "<color>" } " is defined, which reads three values from the stack and creates a " { $snippet "color" } " instance having these values in the " { $snippet "red" } ", " { $snippet "green" } " and " { $snippet "blue" } " slots, respectively."
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -166,7 +166,7 @@ IN: bootstrap.syntax
|
|||
"C:" [
|
||||
CREATE-WORD
|
||||
scan-word dup check-tuple
|
||||
[ construct-boa ] curry define-inline
|
||||
[ boa ] curry define-inline
|
||||
] define-syntax
|
||||
|
||||
"ERROR:" [
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ mailbox variables sleep-entry ;
|
|||
PRIVATE>
|
||||
|
||||
: <thread> ( quot name -- thread )
|
||||
\ thread construct-empty
|
||||
\ thread new
|
||||
swap >>name
|
||||
swap >>quot
|
||||
\ thread counter >>id
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: vectors
|
|||
<PRIVATE
|
||||
|
||||
: array>vector ( array length -- vector )
|
||||
vector construct-boa ; inline
|
||||
vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
|
|||
TUPLE: vocab-link name ;
|
||||
|
||||
: <vocab-link> ( name -- vocab-link )
|
||||
vocab-link construct-boa ;
|
||||
vocab-link boa ;
|
||||
|
||||
M: vocab-link hashcode*
|
||||
vocab-link-name hashcode* ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue