factor: in: to IN: in tests

locals-and-roots
Doug Coleman 2016-06-22 09:18:26 -07:00
parent 701d1823b5
commit 49531c7275
20 changed files with 87 additions and 87 deletions

View File

@ -8,7 +8,7 @@ HELP: <n-based-assoc>
{ $examples { $examples
{ $example " { $example "
USING: assocs prettyprint kernel sequences.n-based ; USING: assocs prettyprint kernel sequences.n-based ;
in: scratchpad IN: scratchpad
: months ( -- assoc ) : months ( -- assoc )
{ {
@ -34,7 +34,7 @@ HELP: n-based-assoc
{ $examples { $examples
{ $example " { $example "
USING: assocs prettyprint kernel sequences.n-based ; USING: assocs prettyprint kernel sequences.n-based ;
in: scratchpad IN: scratchpad
: months ( -- assoc ) : months ( -- assoc )
{ {

View File

@ -137,7 +137,7 @@ symbol: __does_not_exist__
[ [
" "
in: specialized-arrays.tests IN: specialized-arrays.tests
USING: specialized-arrays ; USING: specialized-arrays ;
specialized-array: __does_not_exist__ " eval( -- ) specialized-array: __does_not_exist__ " eval( -- )
@ -145,7 +145,7 @@ specialized-array: __does_not_exist__ " eval( -- )
{ } [ { } [
" "
in: specialized-arrays.tests IN: specialized-arrays.tests
USING: alien.c-types classes.struct specialized-arrays ; USING: alien.c-types classes.struct specialized-arrays ;
STRUCT: __does_not_exist__ { x int } ; STRUCT: __does_not_exist__ { x int } ;
@ -180,7 +180,7 @@ specialized-array: struct-resize-test
{ { 10 20 30 } } [ { 10 20 30 } struct-resize-test-usage ] unit-test { { 10 20 30 } } [ { 10 20 30 } struct-resize-test-usage ] unit-test
{ } [ "in: specialized-arrays.tests use: classes.struct use: alien.c-types STRUCT: struct-resize-test { x int } { y int } ;" eval( -- ) ] unit-test { } [ "IN: specialized-arrays.tests use: classes.struct use: alien.c-types STRUCT: struct-resize-test { x int } { y int } ;" eval( -- ) ] unit-test
{ 80 } [ 10 <struct-resize-test-array> byte-length ] unit-test { 80 } [ 10 <struct-resize-test-array> byte-length ] unit-test

View File

@ -1,5 +1,5 @@
auto-use auto-use
in: syntax IN: syntax
use: delegate.private use: delegate.private
COMPILE< forget: postpone\ MACRO: COMPILE> COMPILE< forget: postpone\ MACRO: COMPILE>
@ -174,4 +174,4 @@ string-lines
disable-optimizer disable-optimizer
enable-optimizer enable-optimizer
in: scratchpad 1 1 - restarts [ nth f ] change-global "peg.ebnf" reload continue-restart IN: scratchpad 1 1 - restarts [ nth f ] change-global "peg.ebnf" reload continue-restart

View File

@ -70,7 +70,7 @@ ARTICLE: "locals-examples" "Examples of lexical variables"
{ $heading "Definitions with lexical variables" } { $heading "Definitions with lexical variables" }
"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link postpone\ :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link postpone\ :> } " and then used in the following line of code." "The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link postpone\ :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link postpone\ :> } " and then used in the following line of code."
{ $example "USING: locals math math.functions kernel ; { $example "USING: locals math math.functions kernel ;
in: scratchpad IN: scratchpad
:: quadratic-roots ( a b c -- x y ) :: quadratic-roots ( a b c -- x y )
b sq 4 a c * * - sqrt :> disc b sq 4 a c * * - sqrt :> disc
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ; b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;
@ -80,7 +80,7 @@ in: scratchpad
} }
"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link postpone\ let[ } " to provide a scope for the variables:" "If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link postpone\ let[ } " to provide a scope for the variables:"
{ $example "USING: locals math math.functions kernel ; { $example "USING: locals math math.functions kernel ;
in: scratchpad IN: scratchpad
let[ 1.0 :> a 1.0 :> b -6.0 :> c let[ 1.0 :> a 1.0 :> b -6.0 :> c
b sq 4 a c * * - sqrt :> disc b sq 4 a c * * - sqrt :> disc
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
@ -95,7 +95,7 @@ $nl
"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link postpone\ |[ } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:" "These next two examples demonstrate lexical variable bindings in quotations defined with " { $link postpone\ |[ } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:"
{ $example { $example
"USING: kernel locals math prettyprint ;" "USING: kernel locals math prettyprint ;"
"in: scratchpad" "IN: scratchpad"
"5 3 |[ m n | m n - ] call ." "5 3 |[ m n | m n - ] call ."
"2" "2"
} }
@ -104,7 +104,7 @@ $nl
"In this example, the " { $snippet "adder" } " word creates a quotation that closes over its argument " { $snippet "n" } ". When called, the result quotation of " { $snippet "5 adder" } " pulls " { $snippet "3" } " off the datastack and binds it to " { $snippet "m" } ", which is added to the value " { $snippet "5" } " bound to " { $snippet "n" } " in the outer scope of " { $snippet "adder" } ":" "In this example, the " { $snippet "adder" } " word creates a quotation that closes over its argument " { $snippet "n" } ". When called, the result quotation of " { $snippet "5 adder" } " pulls " { $snippet "3" } " off the datastack and binds it to " { $snippet "m" } ", which is added to the value " { $snippet "5" } " bound to " { $snippet "n" } " in the outer scope of " { $snippet "adder" } ":"
{ $example { $example
"USING: kernel locals math prettyprint ;" "USING: kernel locals math prettyprint ;"
"in: scratchpad" "IN: scratchpad"
":: adder ( n -- quot ) |[ m | m n + ] ;" ":: adder ( n -- quot ) |[ m | m n + ] ;"
"3 5 adder call ." "3 5 adder call ."
"8" "8"
@ -115,7 +115,7 @@ $nl
"This next example demonstrates closures and mutable variable bindings. The " { $snippet "<counter>" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter." "This next example demonstrates closures and mutable variable bindings. The " { $snippet "<counter>" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
{ $example { $example
"USING: locals kernel math ; "USING: locals kernel math ;
in: scratchpad IN: scratchpad
TUPLE: counter adder subtractor ; TUPLE: counter adder subtractor ;
@ -136,7 +136,7 @@ TUPLE: counter adder subtractor ;
"The same variable name can be bound multiple times in the same scope. This is different from reassigning the value of a mutable variable. The most recent binding for a variable name will mask previous bindings for that name. However, the old binding referring to the previous value can still persist in closures. The following contrived example demonstrates this:" "The same variable name can be bound multiple times in the same scope. This is different from reassigning the value of a mutable variable. The most recent binding for a variable name will mask previous bindings for that name. However, the old binding referring to the previous value can still persist in closures. The following contrived example demonstrates this:"
{ $example { $example
"USING: kernel locals prettyprint ; "USING: kernel locals prettyprint ;
in: scratchpad IN: scratchpad
:: rebinding-example ( -- quot1 quot2 ) :: rebinding-example ( -- quot1 quot2 )
5 :> a [ a ] 5 :> a [ a ]
6 :> a [ a ] ; 6 :> a [ a ] ;
@ -155,7 +155,7 @@ mutable-example [ call . ] bi@"
"Some kinds of literals can include references to lexical variables as described in " { $link "locals-literals" } ". For example, the " { $link 3array } " word could be implemented as follows:" "Some kinds of literals can include references to lexical variables as described in " { $link "locals-literals" } ". For example, the " { $link 3array } " word could be implemented as follows:"
{ $example { $example
"USING: locals prettyprint ; "USING: locals prettyprint ;
in: scratchpad IN: scratchpad
:: my-3array ( x y z -- array ) { x y z } ; :: my-3array ( x y z -- array ) { x y z } ;
1 \"two\" 3.0 my-3array ." 1 \"two\" 3.0 my-3array ."
@ -176,7 +176,7 @@ $nl
{ $heading "Object identity" } { $heading "Object identity" }
"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:" "This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
{ $example { $example
"in: scratchpad" "IN: scratchpad"
"TUPLE: person first-name last-name ;" "TUPLE: person first-name last-name ;"
": ordinary-word-test ( -- tuple )" ": ordinary-word-test ( -- tuple )"
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;" " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
@ -186,7 +186,7 @@ $nl
"Inside a lexical scope, literals which do not contain lexical variables still behave in the same way:" "Inside a lexical scope, literals which do not contain lexical variables still behave in the same way:"
{ $example { $example
"use: locals" "use: locals"
"in: scratchpad" "IN: scratchpad"
"TUPLE: person first-name last-name ;" "TUPLE: person first-name last-name ;"
":: locals-word-test ( -- tuple )" ":: locals-word-test ( -- tuple )"
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;" " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
@ -196,7 +196,7 @@ $nl
"However, literals with lexical variables in them actually construct a new object:" "However, literals with lexical variables in them actually construct a new object:"
{ $example { $example
"USING: locals splitting ;" "USING: locals splitting ;"
"in: scratchpad" "IN: scratchpad"
"TUPLE: person first-name last-name ;" "TUPLE: person first-name last-name ;"
":: constructor-test ( -- tuple )" ":: constructor-test ( -- tuple )"
" \"Jane Smith\" \" \" split1 :> last :> first" " \"Jane Smith\" \" \" split1 :> last :> first"

View File

@ -12,7 +12,7 @@ HELP: \ TYPED:
"A version of " { $link + } " specialized for floats, converting other real number types:" "A version of " { $link + } " specialized for floats, converting other real number types:"
{ $example { $example
"USING: math prettyprint typed ; "USING: math prettyprint typed ;
in: scratchpad IN: scratchpad
TYPED: add-floats ( a: float b: float -- c: float ) TYPED: add-floats ( a: float b: float -- c: float )
+ ; + ;
@ -30,7 +30,7 @@ HELP: \ TYPED::
"A version of the quadratic formula specialized for floats, converting other real number types:" "A version of the quadratic formula specialized for floats, converting other real number types:"
{ $example { $example
"USING: kernel math math.libm prettyprint typed ; "USING: kernel math math.libm prettyprint typed ;
in: scratchpad IN: scratchpad
TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float ) TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float )
b neg b neg

View File

@ -67,7 +67,7 @@ TYPED: unboxy ( in: unboxable -- out: unboxable2 )
[ [
" "
USING: kernel math ; USING: kernel math ;
in: typed.tests IN: typed.tests
TUPLE: unboxable TUPLE: unboxable
{ x fixnum read-only } { x fixnum read-only }
@ -77,7 +77,7 @@ TUPLE: unboxable
" "
USING: accessors kernel math ; USING: accessors kernel math ;
in: typed.tests IN: typed.tests
T{ unboxable f 12 3 4.0 } unboxy xy>> T{ unboxable f 12 3 4.0 } unboxy xy>>
" eval( -- xy ) " eval( -- xy )
] unit-test ] unit-test
@ -128,7 +128,7 @@ TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
{ f } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test { f } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
{ } [ "in: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test { } [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
{ t } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test { t } [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
@ -185,5 +185,5 @@ TYPED: typed-intersection ( x: intersection{ integer bignum } -- ? ) >boolean ;
[ 0 typed-intersection ] [ input-mismatch-error? ] must-fail-with [ 0 typed-intersection ] [ input-mismatch-error? ] must-fail-with
[ [
"in: test123 use: typed TYPED: foo ( x -- y ) ;" eval( -- ) "IN: test123 use: typed TYPED: foo ( x -- y ) ;" eval( -- )
] [ error>> no-types-specified? ] must-fail-with ] [ error>> no-types-specified? ] must-fail-with

View File

@ -46,7 +46,7 @@ ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
{ $examples { $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:" "The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
{ $code "USING: kernel ui.gadgets.worlds ui.pixel-formats ; { $code "USING: kernel ui.gadgets.worlds ui.pixel-formats ;
in: ui.pixel-formats.examples IN: ui.pixel-formats.examples
TUPLE: picky-depth-buffered-world < world ; TUPLE: picky-depth-buffered-world < world ;

View File

@ -178,7 +178,7 @@ ARTICLE: "ui-backend" "Developing UI backends"
ARTICLE: "ui-backend-init" "UI initialization and the event loop" ARTICLE: "ui-backend-init" "UI initialization and the event loop"
"An UI backend is required to define a method on the " { $link (with-ui) } " word. This word should contain backend initialization, together with some boilerplate:" "An UI backend is required to define a method on the " { $link (with-ui) } " word. This word should contain backend initialization, together with some boilerplate:"
{ $code { $code
"in: shells" "IN: shells"
"" ""
": ui" ": ui"
" ... backend-specific initialization ..." " ... backend-specific initialization ..."
@ -351,7 +351,7 @@ HELP: \ WINDOW:
"From the " { $vocab-link "hello-ui" } " vocabulary. Creates a window with the title \"Hi\" containing a label reading \"Hello world\":" "From the " { $vocab-link "hello-ui" } " vocabulary. Creates a window with the title \"Hi\" containing a label reading \"Hello world\":"
{ $code { $code
"USING: accessors ui ui.gadgets.labels ; "USING: accessors ui ui.gadgets.labels ;
in: hello-ui IN: hello-ui
WINDOW: hello { { title \"Hi\" } } WINDOW: hello { { title \"Hi\" } }
\"Hello world\" <label> >>gadgets ;" \"Hello world\" <label> >>gadgets ;"
@ -365,7 +365,7 @@ HELP: \ MAIN-WINDOW:
"From the " { $vocab-link "hello-ui" } " vocabulary. Creates a window with the title \"Hi\" containing a label reading \"Hello world\":" "From the " { $vocab-link "hello-ui" } " vocabulary. Creates a window with the title \"Hi\" containing a label reading \"Hello world\":"
{ $code { $code
"USING: accessors ui ui.gadgets.labels ; "USING: accessors ui ui.gadgets.labels ;
in: hello-ui IN: hello-ui
MAIN-WINDOW: hello { { title \"Hi\" } } MAIN-WINDOW: hello { { title \"Hi\" } }
\"Hello world\" <label> >>gadgets ;" \"Hello world\" <label> >>gadgets ;"

View File

@ -64,7 +64,7 @@ $nl
"USING: accessors alien.c-types alien.data "USING: accessors alien.c-types alien.data
classes.struct kernel math math.functions classes.struct kernel math math.functions
prettyprint ; prettyprint ;
in: scratchpad IN: scratchpad
STRUCT: test-point { x int } { y int } ; STRUCT: test-point { x int } { y int } ;

View File

@ -13,7 +13,7 @@ HELP: \ BE-PACKED-STRUCT:
"BE-PACKED-STRUCT: s1 { a char[7] } { b int } ;" "BE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
"\\ s1 see" "\\ s1 see"
"USING: alien.c-types alien.endian classes.struct ; "USING: alien.c-types alien.endian classes.struct ;
in: scratchpad IN: scratchpad
STRUCT: s1 { a char[7] } { b be32 initial: 0 } ;" STRUCT: s1 { a char[7] } { b be32 initial: 0 } ;"
} ; } ;
@ -26,7 +26,7 @@ HELP: \ BE-STRUCT:
"BE-STRUCT: s1 { a int } { b le32 } ;" "BE-STRUCT: s1 { a int } { b le32 } ;"
"\\ s1 see" "\\ s1 see"
"USING: alien.c-types alien.endian classes.struct ; "USING: alien.c-types alien.endian classes.struct ;
in: scratchpad IN: scratchpad
STRUCT: s1 { a be32 initial: 0 } { b le32 initial: 0 } ;" STRUCT: s1 { a be32 initial: 0 } { b le32 initial: 0 } ;"
} ; } ;
@ -39,7 +39,7 @@ HELP: \ LE-PACKED-STRUCT:
"LE-PACKED-STRUCT: s1 { a char[7] } { b int } ;" "LE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
"\\ s1 see" "\\ s1 see"
"USING: alien.c-types alien.endian classes.struct ; "USING: alien.c-types alien.endian classes.struct ;
in: scratchpad IN: scratchpad
STRUCT: s1 { a char[7] } { b int initial: 0 } ;" STRUCT: s1 { a char[7] } { b int initial: 0 } ;"
} ; } ;
@ -52,7 +52,7 @@ HELP: \ LE-STRUCT:
"LE-STRUCT: s1 { a int } { b be32 } ;" "LE-STRUCT: s1 { a int } { b be32 } ;"
"\\ s1 see" "\\ s1 see"
"USING: alien.c-types alien.endian classes.struct ; "USING: alien.c-types alien.endian classes.struct ;
in: scratchpad IN: scratchpad
STRUCT: s1 { a int initial: 0 } { b be32 initial: 0 } ;" STRUCT: s1 { a int initial: 0 } { b be32 initial: 0 } ;"
} ; } ;

View File

@ -7,7 +7,7 @@ CONSTANT: FOO 10 ;
FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ; FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
FUNCTION: int function_test FUNCTION: int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; ( float x, int[4][FOO] y, char* z, ushort* w ) ;
" } [ " } [
@ -18,7 +18,7 @@ FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort *w ) ; ( float x, int[4][FOO] y, char* z, ushort *w ) ;
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
FUNCTION-ALIAS: function-test int function_test FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ; ( float x, int[4][FOO] y, char* z, ushort* w ) ;
" } [ " } [
@ -29,14 +29,14 @@ TYPEDEF: c-string[ascii] string-typedef ;
TYPEDEF: char[1][2][3] array-typedef ; TYPEDEF: char[1][2][3] array-typedef ;
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
TYPEDEF: c-string[ascii] string-typedef ; TYPEDEF: c-string[ascii] string-typedef ;
" } [ " } [
[ \ string-typedef see ] with-string-writer [ \ string-typedef see ] with-string-writer
] unit-test ] unit-test
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
TYPEDEF: char[1][2][3] array-typedef ; TYPEDEF: char[1][2][3] array-typedef ;
" } [ " } [
[ \ array-typedef see ] with-string-writer [ \ array-typedef see ] with-string-writer
@ -45,7 +45,7 @@ TYPEDEF: char[1][2][3] array-typedef ;
c-type: opaque-c-type c-type: opaque-c-type
{ "USING: alien.syntax ; { "USING: alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
c-type: opaque-c-type c-type: opaque-c-type
" } [ " } [
[ \ opaque-c-type see ] with-string-writer [ \ opaque-c-type see ] with-string-writer
@ -54,7 +54,7 @@ c-type: opaque-c-type
TYPEDEF: pointer: int pint ; TYPEDEF: pointer: int pint ;
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
TYPEDEF: int* pint ; TYPEDEF: int* pint ;
" } [ " } [
[ \ pint see ] with-string-writer [ \ pint see ] with-string-writer
@ -65,7 +65,7 @@ TYPEDEF: int* pint ;
CALLBACK: void callback-test ( int x, float[4] y ) ; CALLBACK: void callback-test ( int x, float[4] y ) ;
{ "USING: alien.c-types alien.syntax ; { "USING: alien.c-types alien.syntax ;
in: alien.prettyprint.tests IN: alien.prettyprint.tests
CALLBACK: void callback-test ( int x, float[4] y ) ; CALLBACK: void callback-test ( int x, float[4] y ) ;
" } [ " } [
[ \ callback-test see ] with-string-writer [ \ callback-test see ] with-string-writer

View File

@ -187,14 +187,14 @@ STRUCT: struct-test-string-ptr
] unit-test ] unit-test
{ "USING: alien.c-types classes.struct ; { "USING: alien.c-types classes.struct ;
in: classes.struct.tests IN: classes.struct.tests
STRUCT: struct-test-foo STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ; { x char initial: 0 } { y int initial: 123 } { z bool } ;
" } " }
[ [ struct-test-foo see ] with-string-writer ] unit-test [ [ struct-test-foo see ] with-string-writer ] unit-test
{ "USING: alien.c-types classes.struct ; { "USING: alien.c-types classes.struct ;
in: classes.struct.tests IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ; { f float initial: 0.0 } { bits uint initial: 0 } ;
" } " }
@ -332,27 +332,27 @@ STRUCT: struct-that's-a-word { x int } ;
! Interactive parsing of struct slot definitions ! Interactive parsing of struct slot definitions
[ [
"use: classes.struct in: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader> "use: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
"struct-class-test-1" parse-stream "struct-class-test-1" parse-stream
] [ error>> error>> unexpected-eof? ] must-fail-with ] [ error>> error>> unexpected-eof? ] must-fail-with
[ [
"USING: alien.c-types classes.struct ; in: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- ) "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with ] [ error>> duplicate-slot-names? ] must-fail-with
[ [
"USING: alien.c-types classes.struct ; in: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- ) "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with ] [ error>> duplicate-slot-names? ] must-fail-with
! S{ with non-struct type ! S{ with non-struct type
[ [
"use: classes.struct in: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }" "use: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value ) eval( -- value )
] [ error>> no-method? ] must-fail-with ] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed ! Subclassing a struct class should not be allowed
[ [
"USING: alien.c-types classes.struct ; in: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;" "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- ) eval( -- )
] [ error>> bad-superclass? ] must-fail-with ] [ error>> bad-superclass? ] must-fail-with
@ -365,7 +365,7 @@ TUPLE: a-subclass < will-become-struct ;
{ will-become-struct } [ a-subclass superclass-of ] unit-test { will-become-struct } [ a-subclass superclass-of ] unit-test
{ } [ "in: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test { } [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
{ t } [ will-become-struct struct-class? ] unit-test { t } [ will-become-struct struct-class? ] unit-test
@ -499,17 +499,17 @@ PACKED-STRUCT: struct-1-packed { a c:int } ;
UNION-STRUCT: struct-1-union { a c:int } ; UNION-STRUCT: struct-1-union { a c:int } ;
{ "USING: alien.c-types classes.struct ; { "USING: alien.c-types classes.struct ;
in: classes.struct.tests IN: classes.struct.tests
STRUCT: struct-1 { a int initial: 0 } ; STRUCT: struct-1 { a int initial: 0 } ;
" } " }
[ \ struct-1 [ see ] with-string-writer ] unit-test [ \ struct-1 [ see ] with-string-writer ] unit-test
{ "USING: alien.c-types classes.struct ; { "USING: alien.c-types classes.struct ;
in: classes.struct.tests IN: classes.struct.tests
PACKED-STRUCT: struct-1-packed { a int initial: 0 } ; PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
" } " }
[ \ struct-1-packed [ see ] with-string-writer ] unit-test [ \ struct-1-packed [ see ] with-string-writer ] unit-test
{ "USING: alien.c-types classes.struct ; { "USING: alien.c-types classes.struct ;
in: classes.struct.tests IN: classes.struct.tests
STRUCT: struct-1-union { a int initial: 0 } ; STRUCT: struct-1-union { a int initial: 0 } ;
" } " }
[ \ struct-1-union [ see ] with-string-writer ] unit-test [ \ struct-1-union [ see ] with-string-writer ] unit-test
@ -517,7 +517,7 @@ STRUCT: struct-1-union { a int initial: 0 } ;
! Bug #206 ! Bug #206
STRUCT: going-to-redefine { a uint } ; STRUCT: going-to-redefine { a uint } ;
{ } [ { } [
"in: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- ) "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
] unit-test ] unit-test
{ f } [ \ going-to-redefine \ clone ?lookup-method ] unit-test { f } [ \ going-to-redefine \ clone ?lookup-method ] unit-test
{ f } [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test { f } [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test

View File

@ -69,7 +69,7 @@ COMPILE>
[ [
"use: constructors "use: constructors
in: constructors.tests IN: constructors.tests
TUPLE: foo a b ; TUPLE: foo a b ;
CONSTRUCTOR: <foo> foo ( a a -- obj )" eval( -- ) CONSTRUCTOR: <foo> foo ( a a -- obj )" eval( -- )
] [ ] [
@ -78,7 +78,7 @@ CONSTRUCTOR: <foo> foo ( a a -- obj )" eval( -- )
[ [
"use: constructors "use: constructors
in: constructors.tests IN: constructors.tests
TUPLE: foo a b ; TUPLE: foo a b ;
CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- ) CONSTRUCTOR: <foo> foo ( a c -- obj )" eval( -- )
] [ ] [

View File

@ -69,12 +69,12 @@ unit-test
: foo ( a -- b ) dup * ; inline : foo ( a -- b ) dup * ; inline
{ "USING: kernel math ;\nin: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" } { "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" }
[ [ \ foo see ] with-string-writer ] unit-test [ [ \ foo see ] with-string-writer ] unit-test
: bar ( x -- y ) 2 + ; : bar ( x -- y ) 2 + ;
{ "USING: math ;\nin: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" } { "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" }
[ [ \ bar see ] with-string-writer ] unit-test [ [ \ bar see ] with-string-writer ] unit-test
: blah ( a a a a a a a a a a a a a a a a a a a a -- ) : blah ( a a a a a a a a a a a a a a a a a a a a -- )
@ -151,7 +151,7 @@ M: object method-layout ;
: soft-break-test ( -- str ) : soft-break-test ( -- str )
{ {
"USING: kernel math sequences strings ;" "USING: kernel math sequences strings ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
": soft-break-layout ( x y -- ? )" ": soft-break-layout ( x y -- ? )"
" over string? [" " over string? ["
" over hashcode over hashcode number=" " over hashcode over hashcode number="
@ -168,7 +168,7 @@ DEFER: parse-error-file
: another-soft-break-test ( -- str ) : another-soft-break-test ( -- str )
{ {
"USING: make sequences ;" "USING: make sequences ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )" ": another-soft-break-layout ( node -- quot )"
" parse-error-file" " parse-error-file"
" [ <reversed> \"hello world foo\" suffix ] [ ] make ;" " [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
@ -182,7 +182,7 @@ DEFER: parse-error-file
: string-layout ( -- str ) : string-layout ( -- str )
{ {
"USING: accessors debugger io kernel ;" "USING: accessors debugger io kernel ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
": string-layout-test ( error -- )" ": string-layout-test ( error -- )"
" \"Expected \" write dup want>> expected>string write" " \"Expected \" write dup want>> expected>string write"
" \" but got \" write got>> expected>string print ;" " \" but got \" write got>> expected>string print ;"
@ -196,7 +196,7 @@ DEFER: parse-error-file
: narrow-test ( -- array ) : narrow-test ( -- array )
{ {
"USING: arrays combinators continuations kernel sequences ;" "USING: arrays combinators continuations kernel sequences ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
": narrow-layout ( obj1 obj2 -- obj3 )" ": narrow-layout ( obj1 obj2 -- obj3 )"
" {" " {"
" { [ dup continuation? ] [ append ] }" " { [ dup continuation? ] [ append ] }"
@ -211,7 +211,7 @@ DEFER: parse-error-file
: another-narrow-test ( -- array ) : another-narrow-test ( -- array )
{ {
"in: prettyprint.tests" "IN: prettyprint.tests"
": another-narrow-layout ( -- obj )" ": another-narrow-layout ( -- obj )"
" H{" " H{"
" { 1 2 }" " { 1 2 }"
@ -239,10 +239,10 @@ M: class-see-layout class-see-layout ;
{ {
{ {
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: class-see-layout ;" "TUPLE: class-see-layout ;"
"" ""
"in: prettyprint.tests" "IN: prettyprint.tests"
"GENERIC: class-see-layout ( x -- y ) ;" "GENERIC: class-see-layout ( x -- y ) ;"
"" ""
} }
@ -264,7 +264,7 @@ M: class-see-layout class-see-layout ;
! Regression ! Regression
{ t } [ { t } [
"in: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) ; flushable\n" "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) ; flushable\n"
dup eval( -- ) dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup-word "generic-decl-test" "prettyprint.tests" lookup-word
[ see ] with-string-writer = [ see ] with-string-writer =
@ -292,13 +292,13 @@ M: f generic-see-test-with-f ;
PREDICATE: predicate-see-test < integer even? ; PREDICATE: predicate-see-test < integer even? ;
{ "USING: math ;\nin: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" } [ { "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" } [
[ \ predicate-see-test see ] with-string-writer [ \ predicate-see-test see ] with-string-writer
] unit-test ] unit-test
INTERSECTION: intersection-see-test sequence number ; INTERSECTION: intersection-see-test sequence number ;
{ "USING: math sequences ;\nin: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" } [ { "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" } [
[ \ intersection-see-test see ] with-string-writer [ \ intersection-see-test see ] with-string-writer
] unit-test ] unit-test
@ -322,7 +322,7 @@ TUPLE: tuple-with-declared-slot { x integer } ;
{ {
{ {
"USING: math ;" "USING: math ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;" "TUPLE: tuple-with-declared-slot { x integer initial: 0 } ;"
"" ""
} }
@ -334,7 +334,7 @@ TUPLE: tuple-with-read-only-slot { x read-only } ;
{ {
{ {
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: tuple-with-read-only-slot { x read-only } ;" "TUPLE: tuple-with-read-only-slot { x read-only } ;"
"" ""
} }
@ -346,7 +346,7 @@ TUPLE: tuple-with-initial-slot { x initial: 123 } ;
{ {
{ {
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: tuple-with-initial-slot { x initial: 123 } ;" "TUPLE: tuple-with-initial-slot { x initial: 123 } ;"
"" ""
} }
@ -359,7 +359,7 @@ TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
{ {
{ {
"USING: math ;" "USING: math ;"
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: tuple-with-initial-declared-slot" "TUPLE: tuple-with-initial-declared-slot"
" { x integer initial: 123 } ;" " { x integer initial: 123 } ;"
"" ""
@ -372,7 +372,7 @@ TUPLE: final-tuple ; final
{ {
{ {
"in: prettyprint.tests" "IN: prettyprint.tests"
"TUPLE: final-tuple ; final" "TUPLE: final-tuple ; final"
"" ""
} }
@ -416,7 +416,7 @@ TUPLE: fo { a intersection{ fixnum integer } } ;
{ {
"USING: math ; "USING: math ;
in: prettyprint.tests IN: prettyprint.tests
TUPLE: mo { a union{ integer float } initial: 0 } ; TUPLE: mo { a union{ integer float } initial: 0 } ;
" "
} [ } [
@ -425,7 +425,7 @@ TUPLE: mo { a union{ integer float } initial: 0 } ;
{ {
"USING: math ; "USING: math ;
in: prettyprint.tests IN: prettyprint.tests
TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ; TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ;
" "
} [ } [

View File

@ -16,7 +16,7 @@ VARIANT: class-name
{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link postpone\ TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." } { $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link postpone\ TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code " { $examples { $code "
USING: kernel variants ; USING: kernel variants ;
in: scratchpad IN: scratchpad
VARIANT: list VARIANT: list
nil nil
@ -28,7 +28,7 @@ HELP: \ VARIANT-MEMBER:
{ $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." } { $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." }
{ $examples { $code " { $examples { $code "
USING: kernel variants ; USING: kernel variants ;
in: scratchpad IN: scratchpad
VARIANT: list ; VARIANT: list ;
@ -41,7 +41,7 @@ HELP: match
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." } { $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
{ $examples { $example " { $examples { $example "
USING: kernel math prettyprint variants ; USING: kernel math prettyprint variants ;
in: scratchpad IN: scratchpad
VARIANT: list VARIANT: list
nil nil

View File

@ -14,13 +14,13 @@ IN: vocabs.prettyprint.tests
: manifest-test-2 ( -- string ) : manifest-test-2 ( -- string )
"USING: kernel namespaces vocabs.parser vocabs.prettyprint ; "USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
in: vocabs.prettyprint.tests IN: vocabs.prettyprint.tests
COMPILE< manifest get pprint-manifest COMPILE>" ; COMPILE< manifest get pprint-manifest COMPILE>" ;
{ {
"USING: kernel namespaces vocabs.parser vocabs.prettyprint ; "USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
in: vocabs.prettyprint.tests" IN: vocabs.prettyprint.tests"
} }
[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test [ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
@ -30,7 +30,7 @@ in: vocabs.prettyprint.tests"
qualified: system qualified: system
QUALIFIED-WITH: assocs a ; QUALIFIED-WITH: assocs a ;
EXCLUDE: parser => run-file ; EXCLUDE: parser => run-file ;
in: vocabs.prettyprint.tests IN: vocabs.prettyprint.tests
COMPILE< manifest get pprint-manifest COMPILE>" ; COMPILE< manifest get pprint-manifest COMPILE>" ;
@ -40,7 +40,7 @@ FROM: math => + - ;
qualified: system qualified: system
QUALIFIED-WITH: assocs a ; QUALIFIED-WITH: assocs a ;
EXCLUDE: parser => run-file ; EXCLUDE: parser => run-file ;
in: vocabs.prettyprint.tests" IN: vocabs.prettyprint.tests"
} }
[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test [ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test

View File

@ -98,7 +98,7 @@ SYMBOLS: x y ;
{ $code { $code
"USING: compiler.tree.debugger kernel.private "USING: compiler.tree.debugger kernel.private
math.vectors math.vectors.simd ; math.vectors math.vectors.simd ;
in: simd-demo IN: simd-demo
: interpolate ( v a b -- w ) : interpolate ( v a b -- w )
{ float-4 float-4 float-4 } declare { float-4 float-4 float-4 } declare
@ -111,7 +111,7 @@ $nl
{ $code { $code
"USING: compiler.tree.debugger hints "USING: compiler.tree.debugger hints
math.vectors math.vectors.simd ; math.vectors math.vectors.simd ;
in: simd-demo IN: simd-demo
: interpolate ( v a b -- w ) : interpolate ( v a b -- w )
[ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ; [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
@ -126,7 +126,7 @@ $nl
"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:" "In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
{ $code { $code
"USING: compiler.tree.debugger math.vectors math.vectors.simd ; "USING: compiler.tree.debugger math.vectors math.vectors.simd ;
in: simd-demo IN: simd-demo
STRUCT: actor STRUCT: actor
{ id int } { id int }

View File

@ -5,7 +5,7 @@
! syntax highlighting and it breaks, things will be badly hightlighted ! syntax highlighting and it breaks, things will be badly hightlighted
! here. ! here.
USING: alien.syntax kernel math ; USING: alien.syntax kernel math ;
in: strange-syntax IN: strange-syntax
TUPLE: a-tuple slot1 slot2 { slot3 integer } ; TUPLE: a-tuple slot1 slot2 { slot3 integer } ;
TUPLE: second-one ; TUPLE: second-one ;

View File

@ -36,7 +36,7 @@
{ "bunny.outlined" "smalltalk.library" "talks.tc-lisp-talk" } diff { "bunny.outlined" "smalltalk.library" "talks.tc-lisp-talk" } diff
[ dup <vocab-link> . flush vocab>literals ] map-zip [ dup <vocab-link> . flush vocab>literals ] map-zip
in: syntax IN: syntax
USING: classes.tuple.parser classes.builtin ; USING: classes.tuple.parser classes.builtin ;

View File

@ -148,7 +148,7 @@ $nl
{ $code "USING: arrays kernel math ;" } { $code "USING: arrays kernel math ;" }
"New words go into the " { $vocab-link "scratchpad" } " vocabulary by default. You can change this with " { $link postpone\ in: } ":" "New words go into the " { $vocab-link "scratchpad" } " vocabulary by default. You can change this with " { $link postpone\ in: } ":"
{ $code { $code
"in: time-machine" "IN: time-machine"
": time-travel ( when what -- ) frob fizz flap ;" ": time-travel ( when what -- ) frob fizz flap ;"
} }
"Note that words must be defined before being referenced. The following is generally invalid:" "Note that words must be defined before being referenced. The following is generally invalid:"
@ -167,7 +167,7 @@ $nl
ARTICLE: "cookbook-application" "Application cookbook" ARTICLE: "cookbook-application" "Application cookbook"
"Vocabularies can define a main entry point:" "Vocabularies can define a main entry point:"
{ $code "in: game-of-life" { $code "IN: game-of-life"
"..." "..."
": play-life ( -- ) ... ;" ": play-life ( -- ) ... ;"
"" ""
@ -211,7 +211,7 @@ command-line get [
"The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:" "The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:"
{ $code "USING: kernel fry io io.files io.encodings.ascii sequences { $code "USING: kernel fry io io.files io.encodings.ascii sequences
regexp command-line namespaces ; regexp command-line namespaces ;
in: grep IN: grep
: grep-lines ( pattern -- ) : grep-lines ( pattern -- )
'[ dup _ matches? [ print ] [ drop ] if ] each-line ; '[ dup _ matches? [ print ] [ drop ] if ] each-line ;