0.79:\r
\r
-- swap @{ and { syntax\r
+- fix prettyprinter\r
+- syntax updates and testing for contrib/\r
- get stuff in examples dir running in the ui\r
- pixelColor replacement\r
-X\r
+\r
+ ui:\r
\r
- make-pane: if no input, just return pane-output\r
! Family names from ethereal
: family-names
-{{
+H{
[[ 1 "Generic" ]] [[ 2 "Location" ]] [[ 3 "Buddylist" ]]
[[ 4 "Messaging" ]] [[ 6 "Invitation" ]] [[ 8 "Popup" ]]
[[ 9 "BOS" ]] [[ 10 "User Lookup" ]] [[ 11 "Stats" ]]
[[ 12 "Translate" ]] [[ 19 "SSI" ]] [[ 21 "ICQ" ]]
- [[ 34 "Unknown Family" ]] }} ;
+ [[ 34 "Unknown Family" ]] } ;
: ch>lower ( int -- int ) dup LETTER? [ HEX: 20 + ] when ;
: ch>upper ( int -- int ) dup letter? [ HEX: 20 - ] when ;
[ [ unswons cons , ] hash-each ] { } make alist>hash ;
: 2list>hash ( keys values -- hash )
- {{ }} clone -rot [ swap pick set-hash ] 2each ;
+ H{ } clone -rot [ swap pick set-hash ] 2each ;
: capability-names
-{{
+H{
[[ "Unknown1" HEX: 094601054c7f11d18222444553540000 ]]
[[ "Games" HEX: 0946134a4c7f11d18222444553540000 ]]
[[ "Send Buddy List" HEX: 0946134b4c7f11d18222444553540000 ]]
[[ "Unknown3" HEX: 094601034c7f11d18222444553540000 ]]
[[ "Buddy Icon" HEX: 094613464c7f11d18222444553540000 ]]
[[ "Add-Ins" HEX: 094613474c7f11d18222444553540000 ]]
-}} ;
+} ;
: capability-values
capability-names hash-swap ;
: capability-abbrevs
-{{
+H{
[[ CHAR: A "Voice" ]]
[[ CHAR: C "Send File" ]]
[[ CHAR: E "AIM Direct IM" ]]
[[ CHAR: G "Add-Ins" ]]
[[ CHAR: H "Get File" ]]
[[ CHAR: K "Send Buddy List" ]]
-}} ;
+} ;
! AIM errors
: aim-errors
-{{
+H{
[[ 1 "Invalid SNAC header." ]]
[[ 2 "Server rate limit exceeded." ]]
[[ 3 "Client rate limit exceeded." ]]
[[ 23 "Request ambiguous." ]]
[[ 24 "Server queue full." ]]
[[ 25 "Not while on AOL." ]]
-}} ;
+} ;
: initialize-aim ( username password -- )
password set username set
- {{ }} clone buddy-hash-name set
- {{ }} clone buddy-hash-id set
- {{ }} clone group-hash-name set
- {{ }} clone group-hash-id set
- {{ }} clone banned-hash-name set
- {{ }} clone banned-hash-id set
+ H{ } clone buddy-hash-name set
+ H{ } clone buddy-hash-id set
+ H{ } clone group-hash-name set
+ H{ } clone group-hash-id set
+ H{ } clone banned-hash-name set
+ H{ } clone banned-hash-id set
<queue> modify-queue set
HEX: 7fff random-int seq-num set
1 stage-num set ;
;
: family-table ( -- hash )
- {{ }} ;
+ H{ } ;
: FAMILY: ( -- fam# )
scan hex> swons dup car family-table hash dup [
drop
] [
- drop {{ }} clone over car family-table set-hash
+ drop H{ } clone over car family-table set-hash
] if ; parsing
: OPCODE: ( fam# -- )
[ t 60 120 ] [
fragile-rpc-server
- << rpc-command f "product" [ 4 5 6 ] >> over send-synchronous >r
- << rpc-command f "add" [ 10 20 30 ] >> over send-synchronous >r
- << rpc-command f "shutdown" [ ] >> swap send-synchronous
+ T{ rpc-command f "product" [ 4 5 6 ] } over send-synchronous >r
+ T{ rpc-command f "add" [ 10 20 30 ] } over send-synchronous >r
+ T{ rpc-command f "shutdown" [ ] } swap send-synchronous
r> r>
] unit-test
#! Return an html fragment dispaying the source
#! of the given word.
dup dup
- {{ }} clone [
+ [
"browser" "responder" set
<table "1" =border table>
<tr> <th "2" =colspan th> "Source" write </th> </tr>
<td "top" =valign td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-simple-html-output </td>
</tr>
</table>
- ] bind ;
+ ] make-hash ;
: display-word-see-form ( url -- )
#! Write out the html for code that accepts
! use this syntax eventually
! JUMP-TABLE: f 4 ( maximum )
-! {{
+! H{
! [[ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] ]]
! [[ 1 [ bitxor bitxor ] ]]
! [[ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] ]]
! [[ 3 [ bitxor bitxor ] ]]
-! }} f-table set
+! } f-table set
! J: 0 f >r over bitnot r> bitand >r bitand r> bitor ;
! J: 1 f bitxor bitxor ;
#! Create the initial global table
continuation-table hash-clear ;
-{{ }} clone table global set-hash
+H{ } clone table global set-hash
#! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ;
#! Remove all existing responders, and create a blank
#! responder table.
global [
- {{ }} clone responders set
+ H{ } clone responders set
! 404 error message pages are served by this guy
[
! The root directory is served by...
"file" set-default-responder
- vhosts nest [ {{ }} clone "default" set ] bind
+ vhosts nest [ H{ } clone "default" set ] bind
] bind
: <foo "<" swap append ;
-: do-<foo write {{ }} clone >n { } clone "attrs" set ;
+: do-<foo write H{ } clone >n V{ } clone "attrs" set ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
: semicolon ( -- semicolon )
#! The semicolon token
- << tok f CHAR: ; >> ;
+ T{ tok f CHAR: ; } ;
: nest-apply ( [ ast ] -- apply )
unswons unit swap [
: functions
#! Regular functions
#! Gives quotation applicable to stack
- {{
+ H{
[ [[ "+" 2 ]] + ]
[ [[ "-" 2 ]] - ]
[ [[ ">" 2 ]] [ > ] infix-relation ]
[ [[ "sn" 3 ]] -rot set-nth ]
[ [[ "prod" 1 ]] product ]
[ [[ "vec" 1 ]] >vector ]
- }} ;
+ } ;
: drc ( list -- list )
#! all of list except last element (backwards cdr)
: high-functions
#! Higher-order functions
#! Gives quotation applicable to quotation and rest of stack
- {{
+ H{
[ [[ "!" 2 ]] 2map ]
[ [[ "!" 1 ]] map ]
[ [[ ">" 2 ]] map-with ]
[ [[ "~" 2 ]] call not ]
[ [[ "/" 2 ]] swapd reduce ]
[ [[ "\\" 2 ]] swapd accumulate ]
- }} ;
+ } ;
: get-hash ( key table -- value )
#! like hash but throws exception if f
[ v>q ] 2apply q* q>v ;
! Zero
-: q0 @{ 0 0 }@ ;
+: q0 { 0 0 } ;
! Units
-: q1 @{ 1 0 }@ ;
-: qi @{ #{ 0 1 }# 0 }@ ;
-: qj @{ 0 1 }@ ;
-: qk @{ 0 #{ 0 1 }# }@ ;
+: q1 { 1 0 } ;
+: qi { C{ 0 1 } 0 } ;
+: qj { 0 1 } ;
+: qk { 0 C{ 0 1 } } ;
! Euler angles -- see
! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
[ t ] [ i c>q qi = ] unit-test
[
- @{ @{ 0 }@ @{ 0 }@ @{ 0 }@ }@
+ { { 0 } { 0 } { 0 } }
] [
3 1 zero-matrix
] unit-test
[
- @{ @{ 1 0 0 }@
- @{ 0 1 0 }@
- @{ 0 0 1 }@ }@
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 } }
] [
3 identity-matrix
] unit-test
[
- @{ @{ 1 0 4 }@
- @{ 0 7 0 }@
- @{ 6 0 3 }@ }@
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
] [
- @{ @{ 1 0 0 }@
- @{ 0 2 0 }@
- @{ 0 0 3 }@ }@
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
- @{ @{ 0 0 4 }@
- @{ 0 5 0 }@
- @{ 6 0 0 }@ }@
+ { { 0 0 4 }
+ { 0 5 0 }
+ { 6 0 0 } }
m+
] unit-test
[
- @{ @{ 1 0 4 }@
- @{ 0 7 0 }@
- @{ 6 0 3 }@ }@
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
] [
- @{ @{ 1 0 0 }@
- @{ 0 2 0 }@
- @{ 0 0 3 }@ }@
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
- @{ @{ 0 0 -4 }@
- @{ 0 -5 0 }@
- @{ -6 0 0 }@ }@
+ { { 0 0 -4 }
+ { 0 -5 0 }
+ { -6 0 0 } }
m-
] unit-test
[
- @{ 10 20 30 }@
+ { 10 20 30 }
] [
- 10 @{ 1 2 3 }@ n*v
+ 10 { 1 2 3 } n*v
] unit-test
[
- @{ 3 4 }@
+ { 3 4 }
] [
- @{ @{ 1 0 }@
- @{ 0 1 }@ }@
+ { { 1 0 }
+ { 0 1 } }
- @{ 3 4 }@
+ { 3 4 }
m.v
] unit-test
[
- @{ 4 3 }@
+ { 4 3 }
] [
- @{ @{ 0 1 }@
- @{ 1 0 }@ }@
+ { { 0 1 }
+ { 1 0 } }
- @{ 3 4 }@
+ { 3 4 }
m.v
] unit-test
-[ @{ 0 0 1 }@ ] [ @{ 1 0 0 }@ @{ 0 1 0 }@ cross ] unit-test
-[ @{ 1 0 0 }@ ] [ @{ 0 1 0 }@ @{ 0 0 1 }@ cross ] unit-test
-[ @{ 0 1 0 }@ ] [ @{ 0 0 1 }@ @{ 1 0 0 }@ cross ] unit-test
+[ { 0 0 1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
+[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
+[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
-[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ ]
-[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ flip flip ]
+[ { { 1 2 } { 3 4 } { 5 6 } } ]
+[ { { 1 2 } { 3 4 } { 5 6 } } flip flip ]
unit-test
-[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ ]
-[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ flip flip ]
+[ { { 1 3 5 } { 2 4 6 } } ]
+[ { { 1 3 5 } { 2 4 6 } } flip flip ]
unit-test
-[ @{ @{ 1 3 5 }@ @{ 2 4 6 }@ }@ ]
-[ @{ @{ 1 2 }@ @{ 3 4 }@ @{ 5 6 }@ }@ flip ]
+[ { { 1 3 5 } { 2 4 6 } } ]
+[ { { 1 2 } { 3 4 } { 5 6 } } flip ]
unit-test
[
- @{ @{ 6 }@ }@
+ { { 6 } }
] [
- @{ @{ 3 }@ }@ @{ @{ 2 }@ }@ m.
+ { { 3 } } { { 2 } } m.
] unit-test
[
- @{ @{ 11 }@ }@
+ { { 11 } }
] [
- @{ @{ 1 3 }@ }@ @{ @{ 5 }@ @{ 2 }@ }@ m.
+ { { 1 3 } } { { 5 } { 2 } } m.
] unit-test
[
- @{ @{ 28 }@ }@
+ { { 28 } }
] [
- @{ @{ 2 4 6 }@ }@
+ { { 2 4 6 } }
- @{ @{ 1 }@
- @{ 2 }@
- @{ 3 }@ }@
+ { { 1 }
+ { 2 }
+ { 3 } }
m.
] unit-test
: instruction-cycles ( -- vector )
#! Return a 256 element vector containing the cycles for
#! each opcode in the 8080 instruction set.
- @{
+ {
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f }@ ;
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
: instructions ( -- vector )
#! Return a 256 element vector containing the emulation words for
#! each opcode in the 8080 instruction set.
- @{
+ {
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f }@ ; inline
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; inline
: not-implemented ( <cpu> -- )
drop ;
#! Given a string containing a register name, return a vector
#! where the 1st item is the getter and the 2nd is the setter
#! for that register.
- {{
+ H{
[[ "A" { cpu-a set-cpu-a } ]]
[[ "B" { cpu-b set-cpu-b } ]]
[[ "C" { cpu-c set-cpu-c } ]]
[[ "DE" { cpu-de set-cpu-de } ]]
[[ "HL" { cpu-hl set-cpu-hl } ]]
[[ "SP" { cpu-sp set-cpu-sp } ]]
- }} hash ;
+ } hash ;
: flag-lookup ( string -- vector )
#! Given a string containing a flag name, return a vector
#! where the 1st item is a word that tests that flag.
- {{
+ H{
[[ "NZ" { flag-nz? } ]]
[[ "NC" { flag-nc? } ]]
[[ "PO" { flag-po? } ]]
[[ "C" { flag-c? } ]]
[[ "P" { flag-p? } ]]
[[ "M" { flag-m? } ]]
- }} hash ;
+ } hash ;
SYMBOL: $1
SYMBOL: $2
: patterns ( -- hashtable )
#! table of code quotation patterns for each type of instruction.
- {{
+ H{
[[ "NOP" [ drop ] ]]
[[ "RET-NN" [ ret-from-sub ] ]]
[[ "RST-0" [ 0 swap (emulate-RST) ] ]]
[[ "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] ]]
[[ "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] ]]
[[ "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] ]]
- }} ;
+ } ;
: 8-bit-registers ( -- parser )
#! A parser for 8-bit registers. On a successfull parse the
#! Given a tuple class return a list of the fields
#! within that tuple. Ignores the delegate field.
[ word-name length 1+ ] keep
- "slots" word-prop 1 swap tail [ ( name-len @{ slot getter setter }@ )
+ "slots" word-prop 1 swap tail [ ( name-len { slot getter setter } )
[ 1 swap nth word-name tail sanitize dup ":" swap append ] keep
0 swap nth
"text"
: init-mappings ( -- )
#!
- {{ }} mappings global set-hash ;
+ H{ } mappings global set-hash ;
: get-mappings ( -- hashtable )
mappings global hash ;
] if ;
: entities
- {{
+ H{
[[ "lt" CHAR: < ]]
[[ "gt" CHAR: > ]]
[[ "amp" CHAR: & ]]
[[ "apos" CHAR: ' ]]
[[ "quot" CHAR: " ]]
- }} ;
+ } ;
: parse-entity ( -- ch )
incr-spot [ CHAR: ; = ] take-until incr-spot
[ contained-name ] keep contained-props 0 <vector> <tag> push-datum ;
M: opener process
- { } clone cons
+ V{ } clone cons
xml-stack get push ;
M: closer process
] keep opener-props r> <tag> push-datum ;
: initialize-xml-stack ( -- )
- f { } clone cons unit >vector xml-stack set ;
+ f V{ } clone cons unit >vector xml-stack set ;
: xml ( string -- vector )
#! Produces a tree of XML nodes
GENERIC: (xml>string) ( object -- )
: reverse-entities ! not as many as entities needed for printing
- {{
+ H{
[[ CHAR: & "amp" ]]
[[ CHAR: < "lt" ]]
[[ CHAR: " "quot" ]]
- }} ;
+ } ;
M: string (xml>string)
[
: PROCESS:
CREATE
- dup {{ }} clone "xtable" set-word-prop
+ dup H{ } clone "xtable" set-word-prop
dup literalize [
"xtable" word-prop
>r dup tag-name r> hash call
: next-x ( x y -- x ) a get * sin swap b get * cos - ;
: next-y ( x y -- y ) swap c get * sin swap d get * cos - ;
-: pixel ( #{ x y }# color -- )
+: pixel ( C{ x y } color -- )
>r >r surface get r> >rect r> pixelColor ;
: iterate-dejong ( x y -- x y )
! parameters
: light
#! Normalized { -1 -3 2 }.
- @{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 }@ ; inline
+ { -0.2672612419124244 -0.8017837257372732 0.5345224838248488 } ; inline
: oversampling 4 ; inline
drop
] if-ray-sphere ;
-: initial-hit << hit f @{ 0.0 0.0 0.0 }@ INF >> ;
+: initial-hit T{ hit f { 0.0 0.0 0.0 } INF } ;
: initial-intersect ( ray scene -- hit )
initial-hit -rot intersect-scene ;
over >r create-center r> 2.0 / >r >r 1 - r> r> create ;
: create-offsets ( quot -- )
- @{
- @{ -1.0 1.0 -1.0 }@
- @{ 1.0 1.0 -1.0 }@
- @{ -1.0 1.0 1.0 }@
- @{ 1.0 1.0 1.0 }@
- }@ swap each ; inline
+ {
+ { -1.0 1.0 -1.0 }
+ { 1.0 1.0 -1.0 }
+ { -1.0 1.0 1.0 }
+ { 1.0 1.0 1.0 }
+ } swap each ; inline
: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
: ray-grid ( point ss-grid -- ray-grid )
[
- [ v+ normalize @{ 0.0 0.0 -4.0 }@ swap <ray> ] map-with
+ [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] map-with
] map-with ;
: ray-pixel ( scene point -- n )
pixel-grid [ [ ray-pixel ] map-with ] map-with ;
: run ( -- string )
- levels @{ 0.0 -1.0 0.0 }@ 1.0 create ray-trace [
+ levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
size size pnm-header
[ [ oversampling sq / pnm-pixel ] each ] each
] "" make ;
SYMBOL: halt
! This is a simple program that outputs 5 1's
-{{
- [[ [[ 1 0 ]] << state f 1 1 2 >> ]]
- [[ [[ 2 0 ]] << state f 1 1 3 >> ]]
- [[ [[ 3 0 ]] << state f 1 -1 1 >> ]]
- [[ [[ 1 1 ]] << state f 1 -1 2 >> ]]
- [[ [[ 2 1 ]] << state f 1 -1 3 >> ]]
- [[ [[ 3 1 ]] << state f 1 -1 halt >> ]]
-}} states set
+H{
+ [[ [[ 1 0 ]] T{ state f 1 1 2 } ]]
+ [[ [[ 2 0 ]] T{ state f 1 1 3 } ]]
+ [[ [[ 3 0 ]] T{ state f 1 -1 1 } ]]
+ [[ [[ 1 1 ]] T{ state f 1 -1 2 } ]]
+ [[ [[ 2 1 ]] T{ state f 1 -1 3 } ]]
+ [[ [[ 3 1 ]] T{ state f 1 -1 halt } ]]
+} states set
! Current state
SYMBOL: state
sequences sequences-internals strings words ;
: <c-type> ( -- type )
- {{
+ H{
[[ "setter" [ "No setter" throw ] ]]
[[ "getter" [ "No getter" throw ] ]]
[[ "boxer" "no boxer" ]]
[[ "unboxer" "no unboxer" ]]
- [[ "reg-class" << int-regs f >> ]]
+ [[ "reg-class" T{ int-regs f } ]]
[[ "width" 0 ]]
- }} clone ;
+ } clone ;
SYMBOL: c-types
: spill-param ( reg-class -- n reg-class )
reg-class-size stack-params [ tuck + ] change
- << stack-params >> ;
+ T{ stack-params } ;
: inc-reg-class ( reg-class -- )
#! On Mac OS X, float parameters 'shadow' integer registers.
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
- [ drop @{ }@ @{ }@ ] [ first2 ] if ;
+ [ drop { } { } ] [ first2 ] if ;
: parse-arglist ( lst -- types stack effect )
unpair [
] "infer" set-word-prop
global [
- "libraries" get [ {{ }} clone "libraries" set ] unless
+ "libraries" get [ H{ } clone "libraries" set ] unless
] bind
M: compound (uncrossref)
over "infer" word-prop or [
drop
] [
- dup @{ "infer-effect" "base-case" "no-effect" "terminates" }@
+ dup { "infer-effect" "base-case" "no-effect" "terminates" }
reset-props update-xt
] if ;
cell "align" set
"box_float" "boxer" set
"unbox_float" "unboxer" set
- << float-regs f 4 >> "reg-class" set
+ T{ float-regs f 4 } "reg-class" set
] "float" define-primitive-type
[
cell 2 * "align" set
"box_double" "boxer" set
"unbox_double" "unboxer" set
- << float-regs f 8 >> "reg-class" set
+ T{ float-regs f 8 } "reg-class" set
] "double" define-primitive-type
! FIXME for 64-bit platforms
boot
] %
- @{
+ {
"/version.factor"
"/library/generic/early-generic.factor"
"/library/cli.factor"
"/library/bootstrap/init.factor"
- }@ [ dup print parse-resource % ] each
+ } [ dup print parse-resource % ] each
[ "/library/bootstrap/boot-stage2.factor" run-resource ] %
] [ ] make
compile? [\r
"Compiling base..." print\r
\r
- @{\r
+ {\r
uncons 1+ 1- + <= > >= mod length\r
nth-unsafe set-nth-unsafe\r
= string>number number>string scan solve-recursion\r
kill-set kill-node (generate)\r
- }@ [ compile ] each\r
+ } [ compile ] each\r
] when\r
\r
compile? [\r
: bignum>seq ( n -- seq )
#! n is positive or zero.
- [ (bignum>seq) ] @{ }@ make ;
+ [ (bignum>seq) ] { } make ;
: emit-bignum ( n -- )
[ 0 < 1 0 ? ] keep abs bignum>seq
: global, ( -- )
[
- @{ vocabularies typemap builtins }@ [ [ ] change ] each
+ { vocabularies typemap builtins } [ [ ] change ] each
] make-hash '
global-offset fixup ;
init-error-handler
default-cli-args
parse-command-line
- "null-stdio" get [ << null-stream f >> stdio set ] when ;
+ "null-stdio" get [ T{ null-stream f } stdio set ] when ;
! These symbols need the same hashcode in the target as in the
! host.
-@{ vocabularies typemap builtins }@
+{ vocabularies typemap builtins }
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab
-{{ }} clone vocabularies set
+H{ } clone vocabularies set
f crossref set
vocabularies get [ "syntax" set [ reveal ] each ] bind
-: make-primitive ( @{ vocab word }@ n -- )
+: make-primitive ( { vocab word } n -- )
>r first2 create r> f define ;
-@{
- @{ "execute" "words" }@
- @{ "call" "kernel" }@
- @{ "if" "kernel" }@
- @{ "dispatch" "kernel-internals" }@
- @{ "cons" "lists" }@
- @{ "<vector>" "vectors" }@
- @{ "rehash-string" "strings" }@
- @{ "<sbuf>" "strings" }@
- @{ "sbuf>string" "strings" }@
- @{ ">fixnum" "math" }@
- @{ ">bignum" "math" }@
- @{ ">float" "math" }@
- @{ "(fraction>)" "math-internals" }@
- @{ "string>float" "math-internals" }@
- @{ "float>string" "math-internals" }@
- @{ "float>bits" "math" }@
- @{ "double>bits" "math" }@
- @{ "bits>float" "math" }@
- @{ "bits>double" "math" }@
- @{ "<complex>" "math-internals" }@
- @{ "fixnum+" "math-internals" }@
- @{ "fixnum-" "math-internals" }@
- @{ "fixnum*" "math-internals" }@
- @{ "fixnum/i" "math-internals" }@
- @{ "fixnum/f" "math-internals" }@
- @{ "fixnum-mod" "math-internals" }@
- @{ "fixnum/mod" "math-internals" }@
- @{ "fixnum-bitand" "math-internals" }@
- @{ "fixnum-bitor" "math-internals" }@
- @{ "fixnum-bitxor" "math-internals" }@
- @{ "fixnum-bitnot" "math-internals" }@
- @{ "fixnum-shift" "math-internals" }@
- @{ "fixnum<" "math-internals" }@
- @{ "fixnum<=" "math-internals" }@
- @{ "fixnum>" "math-internals" }@
- @{ "fixnum>=" "math-internals" }@
- @{ "bignum=" "math-internals" }@
- @{ "bignum+" "math-internals" }@
- @{ "bignum-" "math-internals" }@
- @{ "bignum*" "math-internals" }@
- @{ "bignum/i" "math-internals" }@
- @{ "bignum/f" "math-internals" }@
- @{ "bignum-mod" "math-internals" }@
- @{ "bignum/mod" "math-internals" }@
- @{ "bignum-bitand" "math-internals" }@
- @{ "bignum-bitor" "math-internals" }@
- @{ "bignum-bitxor" "math-internals" }@
- @{ "bignum-bitnot" "math-internals" }@
- @{ "bignum-shift" "math-internals" }@
- @{ "bignum<" "math-internals" }@
- @{ "bignum<=" "math-internals" }@
- @{ "bignum>" "math-internals" }@
- @{ "bignum>=" "math-internals" }@
- @{ "float=" "math-internals" }@
- @{ "float+" "math-internals" }@
- @{ "float-" "math-internals" }@
- @{ "float*" "math-internals" }@
- @{ "float/f" "math-internals" }@
- @{ "float<" "math-internals" }@
- @{ "float<=" "math-internals" }@
- @{ "float>" "math-internals" }@
- @{ "float>=" "math-internals" }@
- @{ "facos" "math-internals" }@
- @{ "fasin" "math-internals" }@
- @{ "fatan" "math-internals" }@
- @{ "fatan2" "math-internals" }@
- @{ "fcos" "math-internals" }@
- @{ "fexp" "math-internals" }@
- @{ "fcosh" "math-internals" }@
- @{ "flog" "math-internals" }@
- @{ "fpow" "math-internals" }@
- @{ "fsin" "math-internals" }@
- @{ "fsinh" "math-internals" }@
- @{ "fsqrt" "math-internals" }@
- @{ "<word>" "words" }@
- @{ "update-xt" "words" }@
- @{ "compiled?" "words" }@
- @{ "drop" "kernel" }@
- @{ "2drop" "kernel" }@
- @{ "3drop" "kernel" }@
- @{ "dup" "kernel" }@
- @{ "2dup" "kernel" }@
- @{ "3dup" "kernel" }@
- @{ "rot" "kernel" }@
- @{ "-rot" "kernel" }@
- @{ "dupd" "kernel" }@
- @{ "swapd" "kernel" }@
- @{ "nip" "kernel" }@
- @{ "2nip" "kernel" }@
- @{ "tuck" "kernel" }@
- @{ "over" "kernel" }@
- @{ "pick" "kernel" }@
- @{ "swap" "kernel" }@
- @{ ">r" "kernel" }@
- @{ "r>" "kernel" }@
- @{ "eq?" "kernel" }@
- @{ "getenv" "kernel-internals" }@
- @{ "setenv" "kernel-internals" }@
- @{ "stat" "io" }@
- @{ "(directory)" "io" }@
- @{ "gc" "memory" }@
- @{ "gc-time" "memory" }@
- @{ "save-image" "memory" }@
- @{ "datastack" "kernel" }@
- @{ "callstack" "kernel" }@
- @{ "set-datastack" "kernel" }@
- @{ "set-callstack" "kernel" }@
- @{ "exit" "kernel" }@
- @{ "room" "memory" }@
- @{ "os-env" "kernel" }@
- @{ "millis" "kernel" }@
- @{ "type" "kernel" }@
- @{ "tag" "kernel-internals" }@
- @{ "cwd" "io" }@
- @{ "cd" "io" }@
- @{ "compiled-offset" "assembler" }@
- @{ "set-compiled-offset" "assembler" }@
- @{ "literal-top" "assembler" }@
- @{ "set-literal-top" "assembler" }@
- @{ "address" "memory" }@
- @{ "dlopen" "alien" }@
- @{ "dlsym" "alien" }@
- @{ "dlclose" "alien" }@
- @{ "<alien>" "alien" }@
- @{ "<byte-array>" "arrays" }@
- @{ "<displaced-alien>" "alien" }@
- @{ "alien-signed-cell" "alien" }@
- @{ "set-alien-signed-cell" "alien" }@
- @{ "alien-unsigned-cell" "alien" }@
- @{ "set-alien-unsigned-cell" "alien" }@
- @{ "alien-signed-8" "alien" }@
- @{ "set-alien-signed-8" "alien" }@
- @{ "alien-unsigned-8" "alien" }@
- @{ "set-alien-unsigned-8" "alien" }@
- @{ "alien-signed-4" "alien" }@
- @{ "set-alien-signed-4" "alien" }@
- @{ "alien-unsigned-4" "alien" }@
- @{ "set-alien-unsigned-4" "alien" }@
- @{ "alien-signed-2" "alien" }@
- @{ "set-alien-signed-2" "alien" }@
- @{ "alien-unsigned-2" "alien" }@
- @{ "set-alien-unsigned-2" "alien" }@
- @{ "alien-signed-1" "alien" }@
- @{ "set-alien-signed-1" "alien" }@
- @{ "alien-unsigned-1" "alien" }@
- @{ "set-alien-unsigned-1" "alien" }@
- @{ "alien-float" "alien" }@
- @{ "set-alien-float" "alien" }@
- @{ "alien-double" "alien" }@
- @{ "set-alien-double" "alien" }@
- @{ "alien-c-string" "alien" }@
- @{ "set-alien-c-string" "alien" }@
- @{ "throw" "errors" }@
- @{ "string>memory" "kernel-internals" }@
- @{ "memory>string" "kernel-internals" }@
- @{ "alien-address" "alien" }@
- @{ "slot" "kernel-internals" }@
- @{ "set-slot" "kernel-internals" }@
- @{ "integer-slot" "kernel-internals" }@
- @{ "set-integer-slot" "kernel-internals" }@
- @{ "char-slot" "kernel-internals" }@
- @{ "set-char-slot" "kernel-internals" }@
- @{ "resize-array" "arrays" }@
- @{ "resize-string" "strings" }@
- @{ "<hashtable>" "hashtables" }@
- @{ "<array>" "arrays" }@
- @{ "<tuple>" "kernel-internals" }@
- @{ "begin-scan" "memory" }@
- @{ "next-object" "memory" }@
- @{ "end-scan" "memory" }@
- @{ "size" "memory" }@
- @{ "die" "kernel" }@
- @{ "flush-icache" "assembler" }@
- @{ "fopen" "io-internals" }@
- @{ "fgetc" "io-internals" }@
- @{ "fwrite" "io-internals" }@
- @{ "fflush" "io-internals" }@
- @{ "fclose" "io-internals" }@
- @{ "expired?" "alien" }@
- @{ "<wrapper>" "kernel" }@
- @{ "(clone)" "kernel-internals" }@
- @{ "(array>tuple)" "kernel-internals" }@
- @{ "tuple>array" "generic" }@
- @{ "array>vector" "vectors" }@
-}@ dup length 3 swap [ + ] map-with [ make-primitive ] 2each
-
-: set-stack-effect ( @{ vocab word effect }@ -- )
+{
+ { "execute" "words" }
+ { "call" "kernel" }
+ { "if" "kernel" }
+ { "dispatch" "kernel-internals" }
+ { "cons" "lists" }
+ { "<vector>" "vectors" }
+ { "rehash-string" "strings" }
+ { "<sbuf>" "strings" }
+ { "sbuf>string" "strings" }
+ { ">fixnum" "math" }
+ { ">bignum" "math" }
+ { ">float" "math" }
+ { "(fraction>)" "math-internals" }
+ { "string>float" "math-internals" }
+ { "float>string" "math-internals" }
+ { "float>bits" "math" }
+ { "double>bits" "math" }
+ { "bits>float" "math" }
+ { "bits>double" "math" }
+ { "<complex>" "math-internals" }
+ { "fixnum+" "math-internals" }
+ { "fixnum-" "math-internals" }
+ { "fixnum*" "math-internals" }
+ { "fixnum/i" "math-internals" }
+ { "fixnum/f" "math-internals" }
+ { "fixnum-mod" "math-internals" }
+ { "fixnum/mod" "math-internals" }
+ { "fixnum-bitand" "math-internals" }
+ { "fixnum-bitor" "math-internals" }
+ { "fixnum-bitxor" "math-internals" }
+ { "fixnum-bitnot" "math-internals" }
+ { "fixnum-shift" "math-internals" }
+ { "fixnum<" "math-internals" }
+ { "fixnum<=" "math-internals" }
+ { "fixnum>" "math-internals" }
+ { "fixnum>=" "math-internals" }
+ { "bignum=" "math-internals" }
+ { "bignum+" "math-internals" }
+ { "bignum-" "math-internals" }
+ { "bignum*" "math-internals" }
+ { "bignum/i" "math-internals" }
+ { "bignum/f" "math-internals" }
+ { "bignum-mod" "math-internals" }
+ { "bignum/mod" "math-internals" }
+ { "bignum-bitand" "math-internals" }
+ { "bignum-bitor" "math-internals" }
+ { "bignum-bitxor" "math-internals" }
+ { "bignum-bitnot" "math-internals" }
+ { "bignum-shift" "math-internals" }
+ { "bignum<" "math-internals" }
+ { "bignum<=" "math-internals" }
+ { "bignum>" "math-internals" }
+ { "bignum>=" "math-internals" }
+ { "float=" "math-internals" }
+ { "float+" "math-internals" }
+ { "float-" "math-internals" }
+ { "float*" "math-internals" }
+ { "float/f" "math-internals" }
+ { "float<" "math-internals" }
+ { "float<=" "math-internals" }
+ { "float>" "math-internals" }
+ { "float>=" "math-internals" }
+ { "facos" "math-internals" }
+ { "fasin" "math-internals" }
+ { "fatan" "math-internals" }
+ { "fatan2" "math-internals" }
+ { "fcos" "math-internals" }
+ { "fexp" "math-internals" }
+ { "fcosh" "math-internals" }
+ { "flog" "math-internals" }
+ { "fpow" "math-internals" }
+ { "fsin" "math-internals" }
+ { "fsinh" "math-internals" }
+ { "fsqrt" "math-internals" }
+ { "<word>" "words" }
+ { "update-xt" "words" }
+ { "compiled?" "words" }
+ { "drop" "kernel" }
+ { "2drop" "kernel" }
+ { "3drop" "kernel" }
+ { "dup" "kernel" }
+ { "2dup" "kernel" }
+ { "3dup" "kernel" }
+ { "rot" "kernel" }
+ { "-rot" "kernel" }
+ { "dupd" "kernel" }
+ { "swapd" "kernel" }
+ { "nip" "kernel" }
+ { "2nip" "kernel" }
+ { "tuck" "kernel" }
+ { "over" "kernel" }
+ { "pick" "kernel" }
+ { "swap" "kernel" }
+ { ">r" "kernel" }
+ { "r>" "kernel" }
+ { "eq?" "kernel" }
+ { "getenv" "kernel-internals" }
+ { "setenv" "kernel-internals" }
+ { "stat" "io" }
+ { "(directory)" "io" }
+ { "gc" "memory" }
+ { "gc-time" "memory" }
+ { "save-image" "memory" }
+ { "datastack" "kernel" }
+ { "callstack" "kernel" }
+ { "set-datastack" "kernel" }
+ { "set-callstack" "kernel" }
+ { "exit" "kernel" }
+ { "room" "memory" }
+ { "os-env" "kernel" }
+ { "millis" "kernel" }
+ { "type" "kernel" }
+ { "tag" "kernel-internals" }
+ { "cwd" "io" }
+ { "cd" "io" }
+ { "compiled-offset" "assembler" }
+ { "set-compiled-offset" "assembler" }
+ { "literal-top" "assembler" }
+ { "set-literal-top" "assembler" }
+ { "address" "memory" }
+ { "dlopen" "alien" }
+ { "dlsym" "alien" }
+ { "dlclose" "alien" }
+ { "<alien>" "alien" }
+ { "<byte-array>" "arrays" }
+ { "<displaced-alien>" "alien" }
+ { "alien-signed-cell" "alien" }
+ { "set-alien-signed-cell" "alien" }
+ { "alien-unsigned-cell" "alien" }
+ { "set-alien-unsigned-cell" "alien" }
+ { "alien-signed-8" "alien" }
+ { "set-alien-signed-8" "alien" }
+ { "alien-unsigned-8" "alien" }
+ { "set-alien-unsigned-8" "alien" }
+ { "alien-signed-4" "alien" }
+ { "set-alien-signed-4" "alien" }
+ { "alien-unsigned-4" "alien" }
+ { "set-alien-unsigned-4" "alien" }
+ { "alien-signed-2" "alien" }
+ { "set-alien-signed-2" "alien" }
+ { "alien-unsigned-2" "alien" }
+ { "set-alien-unsigned-2" "alien" }
+ { "alien-signed-1" "alien" }
+ { "set-alien-signed-1" "alien" }
+ { "alien-unsigned-1" "alien" }
+ { "set-alien-unsigned-1" "alien" }
+ { "alien-float" "alien" }
+ { "set-alien-float" "alien" }
+ { "alien-double" "alien" }
+ { "set-alien-double" "alien" }
+ { "alien-c-string" "alien" }
+ { "set-alien-c-string" "alien" }
+ { "throw" "errors" }
+ { "string>memory" "kernel-internals" }
+ { "memory>string" "kernel-internals" }
+ { "alien-address" "alien" }
+ { "slot" "kernel-internals" }
+ { "set-slot" "kernel-internals" }
+ { "integer-slot" "kernel-internals" }
+ { "set-integer-slot" "kernel-internals" }
+ { "char-slot" "kernel-internals" }
+ { "set-char-slot" "kernel-internals" }
+ { "resize-array" "arrays" }
+ { "resize-string" "strings" }
+ { "<hashtable>" "hashtables" }
+ { "<array>" "arrays" }
+ { "<tuple>" "kernel-internals" }
+ { "begin-scan" "memory" }
+ { "next-object" "memory" }
+ { "end-scan" "memory" }
+ { "size" "memory" }
+ { "die" "kernel" }
+ { "flush-icache" "assembler" }
+ { "fopen" "io-internals" }
+ { "fgetc" "io-internals" }
+ { "fwrite" "io-internals" }
+ { "fflush" "io-internals" }
+ { "fclose" "io-internals" }
+ { "expired?" "alien" }
+ { "<wrapper>" "kernel" }
+ { "(clone)" "kernel-internals" }
+ { "(array>tuple)" "kernel-internals" }
+ { "tuple>array" "generic" }
+ { "array>vector" "vectors" }
+} dup length 3 swap [ + ] map-with [ make-primitive ] 2each
+
+: set-stack-effect ( { vocab word effect } -- )
first3 >r lookup r> "stack-effect" set-word-prop ;
-@{
- @{ "drop" "kernel" " x -- " }@
- @{ "2drop" "kernel" " x y -- " }@
- @{ "3drop" "kernel" " x y z -- " }@
- @{ "dup" "kernel" " x -- x x " }@
- @{ "2dup" "kernel" " x y -- x y x y " }@
- @{ "3dup" "kernel" " x y z -- x y z x y z " }@
- @{ "rot" "kernel" " x y z -- y z x " }@
- @{ "-rot" "kernel" " x y z -- z x y " }@
- @{ "dupd" "kernel" " x y -- x x y " }@
- @{ "swapd" "kernel" " x y z -- y x z " }@
- @{ "nip" "kernel" " x y -- y " }@
- @{ "2nip" "kernel" " x y z -- z " }@
- @{ "tuck" "kernel" " x y -- y x y " }@
- @{ "over" "kernel" " x y -- x y x " }@
- @{ "pick" "kernel" " x y z -- x y z x " }@
- @{ "swap" "kernel" " x y -- y x " }@
- @{ ">r" "kernel" " x -- r: x " }@
- @{ "r>" "kernel" " r: x -- x " }@
- @{ "datastack" "kernel" " -- ds " }@
- @{ "callstack" "kernel" " -- cs " }@
- @{ "set-datastack" "kernel" " ds -- " }@
- @{ "set-callstack" "kernel" " cs -- " }@
- @{ "flush-icache" "assembler" " -- " }@
-}@ [
+{
+ { "drop" "kernel" " x -- " }
+ { "2drop" "kernel" " x y -- " }
+ { "3drop" "kernel" " x y z -- " }
+ { "dup" "kernel" " x -- x x " }
+ { "2dup" "kernel" " x y -- x y x y " }
+ { "3dup" "kernel" " x y z -- x y z x y z " }
+ { "rot" "kernel" " x y z -- y z x " }
+ { "-rot" "kernel" " x y z -- z x y " }
+ { "dupd" "kernel" " x y -- x x y " }
+ { "swapd" "kernel" " x y z -- y x z " }
+ { "nip" "kernel" " x y -- y " }
+ { "2nip" "kernel" " x y z -- z " }
+ { "tuck" "kernel" " x y -- y x y " }
+ { "over" "kernel" " x y -- x y x " }
+ { "pick" "kernel" " x y z -- x y z x " }
+ { "swap" "kernel" " x y -- y x " }
+ { ">r" "kernel" " x -- r: x " }
+ { "r>" "kernel" " r: x -- x " }
+ { "datastack" "kernel" " -- ds " }
+ { "callstack" "kernel" " -- cs " }
+ { "set-datastack" "kernel" " ds -- " }
+ { "set-callstack" "kernel" " cs -- " }
+ { "flush-icache" "assembler" " -- " }
+} [
set-stack-effect
] each
define-slots
register-builtin ;
-{{ }} clone typemap set
+H{ } clone typemap set
num-types <array> builtins set
! These symbols are needed by the code that executes below
"null" "generic" create drop
"fixnum?" "math" create t "inline" set-word-prop
-"fixnum" "math" create 0 "fixnum?" "math" create @{ }@ define-builtin
+"fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
"fixnum" "math" create 0 "math-priority" set-word-prop
"fixnum" "math" create ">fixnum" [ "math" ] search unit "coercer" set-word-prop
"bignum?" "math" create t "inline" set-word-prop
-"bignum" "math" create 1 "bignum?" "math" create @{ }@ define-builtin
+"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create 1 "math-priority" set-word-prop
"bignum" "math" create ">bignum" [ "math" ] search unit "coercer" set-word-prop
"cons?" "lists" create t "inline" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
-@{ @{ 0 @{ "car" "lists" }@ f }@ @{ 1 @{ "cdr" "lists" }@ f }@ }@ define-builtin
+{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
"ratio?" "math" create t "inline" set-word-prop
"ratio" "math" create 4 "ratio?" "math" create
-@{ @{ 0 @{ "numerator" "math" }@ f }@ @{ 1 @{ "denominator" "math" }@ f }@ }@ define-builtin
+{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
"ratio" "math" create 2 "math-priority" set-word-prop
"float?" "math" create t "inline" set-word-prop
-"float" "math" create 5 "float?" "math" create @{ }@ define-builtin
+"float" "math" create 5 "float?" "math" create { } define-builtin
"float" "math" create 3 "math-priority" set-word-prop
"float" "math" create ">float" [ "math" ] search unit "coercer" set-word-prop
"complex?" "math" create t "inline" set-word-prop
"complex" "math" create 6 "complex?" "math" create
-@{ @{ 0 @{ "real" "math" }@ f }@ @{ 1 @{ "imaginary" "math" }@ f }@ }@ define-builtin
+{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
"complex" "math" create 4 "math-priority" set-word-prop
-"displaced-alien" "alien" create 7 "displaced-alien?" "alien" create @{ }@ define-builtin
+"displaced-alien" "alien" create 7 "displaced-alien?" "alien" create { } define-builtin
"array?" "arrays" create t "inline" set-word-prop
"array" "arrays" create 8 "array?" "arrays" create
-@{ }@ define-builtin
+{ } define-builtin
"f" "!syntax" create 9 "not" "kernel" create
-@{ }@ define-builtin
+{ } define-builtin
"hashtable?" "hashtables" create t "inline" set-word-prop
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
-@{
- @{ 1 @{ "hash-size" "hashtables" }@ @{ "set-hash-size" "kernel-internals" }@ }@
- @{ 2 @{ "underlying" "sequences-internals" }@ @{ "set-underlying" "sequences-internals" }@ }@
-}@ define-builtin
+{
+ { 1 { "hash-size" "hashtables" } { "set-hash-size" "kernel-internals" } }
+ { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+} define-builtin
"vector?" "vectors" create t "inline" set-word-prop
"vector" "vectors" create 11 "vector?" "vectors" create
-@{
- @{ 1 @{ "length" "sequences" }@ @{ "set-fill" "sequences-internals" }@ }@
- @{ 2 @{ "underlying" "sequences-internals" }@ @{ "set-underlying" "sequences-internals" }@ }@
-}@ define-builtin
+{
+ { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
+ { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+} define-builtin
"string?" "strings" create t "inline" set-word-prop
"string" "strings" create 12 "string?" "strings" create
-@{
- @{ 1 @{ "length" "sequences" }@ f }@
- @{ 2 @{ "hashcode" "kernel" }@ f }@
-}@ define-builtin
+{
+ { 1 { "length" "sequences" } f }
+ { 2 { "hashcode" "kernel" } f }
+} define-builtin
"sbuf?" "strings" create t "inline" set-word-prop
"sbuf" "strings" create 13 "sbuf?" "strings" create
-@{
- @{ 1 @{ "length" "sequences" }@ @{ "set-fill" "sequences-internals" }@ }@
- @{ 2 @{ "underlying" "sequences-internals" }@ @{ "set-underlying" "sequences-internals" }@ }@
-}@ define-builtin
+{
+ { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
+ { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+} define-builtin
"wrapper?" "kernel" create t "inline" set-word-prop
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
-@{ @{ 1 @{ "wrapped" "kernel" }@ f }@ }@ define-builtin
+{ { 1 { "wrapped" "kernel" } f } } define-builtin
"dll?" "alien" create t "inline" set-word-prop
"dll" "alien" create 15 "dll?" "alien" create
-@{ @{ 1 @{ "dll-path" "alien" }@ f }@ }@ define-builtin
+{ { 1 { "dll-path" "alien" } f } } define-builtin
"alien?" "alien" create t "inline" set-word-prop
-"alien" "alien" create 16 "alien?" "alien" create @{ }@ define-builtin
+"alien" "alien" create 16 "alien?" "alien" create { } define-builtin
"word?" "words" create t "inline" set-word-prop
"word" "words" create 17 "word?" "words" create
-@{
- @{ 1 @{ "hashcode" "kernel" }@ f }@
- @{ 2 @{ "word-name" "words" }@ f }@
- @{ 3 @{ "word-vocabulary" "words" }@ @{ "set-word-vocabulary" "words" }@ }@
- @{ 4 @{ "word-primitive" "words" }@ @{ "set-word-primitive" "words" }@ }@
- @{ 5 @{ "word-def" "words" }@ @{ "set-word-def" "words" }@ }@
- @{ 6 @{ "word-props" "words" }@ @{ "set-word-props" "words" }@ }@
-}@ define-builtin
+{
+ { 1 { "hashcode" "kernel" } f }
+ { 2 { "word-name" "words" } f }
+ { 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
+ { 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
+ { 5 { "word-def" "words" } { "set-word-def" "words" } }
+ { 6 { "word-props" "words" } { "set-word-props" "words" } }
+} define-builtin
"tuple?" "kernel" create t "inline" set-word-prop
"tuple" "kernel" create 18 "tuple?" "kernel" create
-@{ }@ define-builtin
+{ } define-builtin
"byte-array?" "arrays" create t "inline" set-word-prop
"byte-array" "arrays" create 19
"byte-array?" "arrays" create
-@{ }@ define-builtin
+{ } define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create dup define-symbol
! Null class with no instances.
"null" "generic" create [ drop f ] "predicate" set-word-prop
-"null" "generic" create dup define-symbol f @{ }@ define-union
+"null" "generic" create dup define-symbol f { } define-union
FORGET: builtin-predicate
FORGET: register-builtin
M: byte-array length array-capacity ;
M: byte-array resize resize-array ;
-: 1array ( x -- @{ x }@ )
+: 1array ( x -- { x } )
1 <array> [ 0 swap set-array-nth ] keep ; flushable
-: 2array ( x y -- @{ x y }@ )
+: 2array ( x y -- { x y } )
2 <array>
[ 1 swap set-array-nth ] keep
[ 0 swap set-array-nth ] keep ; flushable
-: 3array ( x y z -- @{ x y z }@ )
+: 3array ( x y z -- { x y z } )
3 <array>
[ 2 swap set-array-nth ] keep
[ 1 swap set-array-nth ] keep
2dup hash-contained? >r swap hash-contained? r> and ;
M: hashtable = ( obj hash -- ? )
- @{
- @{ [ 2dup eq? ] [ 2drop t ] }@
- @{ [ over hashtable? not ] [ 2drop f ] }@
- @{ [ 2dup [ hash-size ] 2apply number= not ] [ 2drop f ] }@
- @{ [ t ] [ hashtable= ] }@
- }@ cond ;
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ over hashtable? not ] [ 2drop f ] }
+ { [ 2dup [ hash-size ] 2apply number= not ] [ 2drop f ] }
+ { [ t ] [ hashtable= ] }
+ } cond ;
M: hashtable hashcode ( hash -- n )
#! Poor.
over 0 number= [ nip car ] [ >r 1- r> cdr nth ] if ;
M: cons = ( obj cons -- ? )
- @{
- @{ [ 2dup eq? ] [ 2drop t ] }@
- @{ [ over cons? not ] [ 2drop f ] }@
- @{ [ t ] [ 2dup 2car = >r 2cdr = r> and ] }@
- }@ cond ;
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ over cons? not ] [ 2drop f ] }
+ { [ t ] [ 2dup 2car = >r 2cdr = r> and ] }
+ } cond ;
M: f = ( obj f -- ? ) eq? ;
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
- dup namespace hash [ ] [ >r {{ }} clone dup r> set ] ?if ;
+ dup namespace hash [ ] [ >r H{ } clone dup r> set ] ?if ;
: change ( var quot -- )
#! Execute the quotation with the variable value on the
#! Execute a quotation with a namespace on the namestack.
swap >n call n> drop ; inline
-: make-hash ( quot -- hash ) {{ }} clone >n call n> ; inline
+: make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
: with-scope ( quot -- ) make-hash drop ; inline
: closure ( key hash -- list )
[
- {{ }} clone hash-buffer set
+ H{ } clone hash-buffer set
(closure)
hash-buffer get hash-keys
] with-scope ;
swap [ with rot ] subset 2nip ; inline
: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
- #! Eg, @{ 1 2 3 4 }@ [ < ] monotonic? ==> t
- #! @{ 1 3 2 4 }@ [ < ] monotonic? ==> f
+ #! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t
+ #! { 1 3 2 4 } [ < ] monotonic? ==> f
#! Don't use with lists.
swap dup length 1- [
pick pick >r >r (monotonic) r> r> rot
IN: sequences
-: first2 ( @{ x y }@ -- x y )
+: first2 ( { x y } -- x y )
1 swap bounds-check nip first2-unsafe ; inline
-: first3 ( @{ x y z }@ -- x y z )
+: first3 ( { x y z } -- x y z )
2 swap bounds-check nip first3-unsafe ; inline
-: first4 ( @{ x y z w }@ -- x y z w )
+: first4 ( { x y z w } -- x y z w )
3 swap bounds-check nip first4-unsafe ; inline
M: object like drop ;
: flip ( seq -- seq )
#! An example illustrates this word best:
- #! @{ @{ 1 2 3 }@ @{ 4 5 6 }@ }@ ==> @{ @{ 1 4 }@ @{ 2 5 }@ @{ 3 6 }@ }@
+ #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 4 } { 2 5 } { 3 6 } }
dup empty? [
dup first [ length ] keep like
[ swap [ nth ] map-with ] map-with
: cond ( conditions -- )
#! Conditions is a sequence of quotation pairs.
- #! @{ @{ [ X ] [ Y ] }@ @{ [ Z ] [ T ] }@ }@
+ #! { { [ X ] [ Y ] } { [ Z ] [ T ] } }
#! => X [ Y ] [ Z [ T ] [ ] if ] if
#! The last condition should be a catch-all 't'.
[ first call ] find nip dup
2dup head , dupd tail-slice (group)
] if ;
-: group ( n seq -- seq ) [ (group) ] @{ }@ make ; flushable
+: group ( n seq -- seq ) [ (group) ] { } make ; flushable
: start-step ( subseq seq n -- subseq slice )
pick length dupd + rot <slice> ;
compiled-offset 0 compile-cell ;
: init-assembler ( -- )
- {{ }} clone interned-literals global set-hash ;
+ H{ } clone interned-literals global set-hash ;
: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
] if ;
: split-blocks ( linear -- blocks )
- [ 0 swap (split-blocks) ] @{ }@ make ;
+ [ 0 swap (split-blocks) ] { } make ;
SYMBOL: d-height
SYMBOL: r-height
: preserves-location? ( exitcc location vop -- ? )
#! If the VOP writes the register, call the loop exit
#! continuation with 'f'.
- @{
- @{ [ 2dup vop-inputs member? ] [ 3drop t ] }@
- @{ [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }@
- @{ [ t ] [ 3drop f ] }@
- }@ cond ;
+ {
+ { [ 2dup vop-inputs member? ] [ 3drop t ] }
+ { [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }
+ { [ t ] [ 3drop f ] }
+ } cond ;
GENERIC: live@end? ( location -- ? )
[
0 d-height set
0 r-height set
- {{ }} clone vreg-contents set
+ H{ } clone vreg-contents set
dup simplify-stack
d-height get %inc-d r-height get %inc-r 2array append
trim-dead
- ] @{ }@ make ;
+ ] { } make ;
: keep-simplifying ( block -- block )
dup length >r simplify-block dup length r> =
: (generate) ( word linear -- )
#! Compile a word definition from linear IR.
- { } clone relocation-table set
+ V{ } clone relocation-table set
dup set-stack-reserve
begin-assembly swap >r >r
generate-code
over binary-op-imm?
[ binary-op-imm ] [ binary-op-reg ] if ;
-@{
- @{ fixnum+ %fixnum+ }@
- @{ fixnum- %fixnum- }@
- @{ fixnum-bitand %fixnum-bitand }@
- @{ fixnum-bitor %fixnum-bitor }@
- @{ fixnum-bitxor %fixnum-bitxor }@
-}@ [
+{
+ { fixnum+ %fixnum+ }
+ { fixnum- %fixnum- }
+ { fixnum-bitand %fixnum-bitand }
+ { fixnum-bitor %fixnum-bitor }
+ { fixnum-bitxor %fixnum-bitxor }
+} [
first2 [ binary-op ] curry "intrinsic" set-word-prop
] each
pick binary-op-imm?
[ binary-jump-imm ] [ binary-jump-reg ] if ;
-@{
- @{ fixnum<= %jump-fixnum<= }@
- @{ fixnum< %jump-fixnum< }@
- @{ fixnum>= %jump-fixnum>= }@
- @{ fixnum> %jump-fixnum> }@
- @{ eq? %jump-eq? }@
-}@ [
+{
+ { fixnum<= %jump-fixnum<= }
+ { fixnum< %jump-fixnum< }
+ { fixnum>= %jump-fixnum>= }
+ { fixnum> %jump-fixnum> }
+ { eq? %jump-eq? }
+} [
first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
] each
in-2
-1 %inc-d ,
1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
- << vreg f 2 >> 0 %replace-d ,
+ T{ vreg f 2 } 0 %replace-d ,
] "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
drop
in-2
- @{ << vreg f 1 >> << vreg f 0 >> }@
- @{ << vreg f 2 >> << vreg f 0 >> }@
+ { T{ vreg f 1 } T{ vreg f 0 } }
+ { T{ vreg f 2 } T{ vreg f 0 } }
%fixnum/mod ,
- << vreg f 2 >> 0 %replace-d ,
- << vreg f 0 >> 1 %replace-d ,
+ T{ vreg f 2 } 0 %replace-d ,
+ T{ vreg f 0 } 1 %replace-d ,
] "intrinsic" set-word-prop
\ fixnum-bitnot [
in-1
dup cell -8 * <= [
drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
- << vreg f 2 >> 0 %replace-d ,
+ T{ vreg f 2 } 0 %replace-d ,
] [
neg 0 <vreg> 0 <vreg> %fixnum>> ,
out-1
#! Transform dataflow IR into linear IR. This strips out
#! stack flow information, and flattens conditionals into
#! jumps and labels.
- [ %prologue , linearize* ] @{ }@ make ;
+ [ %prologue , linearize* ] { } make ;
: linearize-next node-successor linearize* ;
: computed>stack >r get <vreg> swap r> execute , ;
: vreg>stack ( stack-pos value storer -- )
- @{
- @{ [ over not ] [ 3drop ] }@
- @{ [ over literal? ] [ literal>stack ] }@
- @{ [ t ] [ computed>stack ] }@
- }@ cond ; inline
+ {
+ { [ over not ] [ 3drop ] }
+ { [ over literal? ] [ literal>stack ] }
+ { [ t ] [ computed>stack ] }
+ } cond ; inline
: (vregs>stack) ( stack storer -- )
swap reverse-slice [ length ] keep
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
: in-3 0 2 %peek-d , 1 1 %peek-d , 2 0 %peek-d , ;
-: out-1 << vreg f 0 >> 0 %replace-d , ;
+: out-1 T{ vreg f 0 } 0 %replace-d , ;
! indirect load of a literal through a table
TUPLE: %indirect ;
#! Number of vregs
3 ; inline
-M: vreg v>operand vreg-n @{ EAX ECX EDX }@ nth ;
+M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
! On x86, parameters are never passed in registers.
M: int-regs fastcall-regs drop 0 ;
[
deferred-xts off
compiled-xts off
- { } clone compile-words set
+ V{ } clone compile-words set
call
fixup-xts
commit-xts
global [
f <void*> dup FT_Init_FreeType freetype-error
*void* freetype set
- {{ }} clone open-fonts set
+ H{ } clone open-fonts set
] bind ;
: free-sprite ( sprite -- )
: flush-font ( font -- )
#! Only do this after re-creating a GL context!
dup font-sprites [ [ free-sprite ] when* ] each
- { } clone swap set-font-sprites ;
+ V{ } clone swap set-font-sprites ;
: close-font ( font -- )
dup flush-font font-handle FT_Done_Face ;
init-freetype [ close-freetype ] cleanup ; inline
: ttf-name ( font style -- name )
- cons {{
+ cons H{
[[ [[ "Monospaced" plain ]] "VeraMono" ]]
[[ [[ "Monospaced" bold ]] "VeraMoBd" ]]
[[ [[ "Monospaced" bold-italic ]] "VeraMoBI" ]]
[[ [[ "Serif" bold ]] "VeraSeBd" ]]
[[ [[ "Serif" bold-italic ]] "VeraBI" ]]
[[ [[ "Serif" italic ]] "VeraIt" ]]
- }} hash ;
+ } hash ;
: ttf-path ( name -- string )
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
C: font ( handle -- font )
[ set-font-handle ] keep dup flush-font dup init-font ;
-: open-font ( @{ font style ptsize }@ -- font )
+: open-font ( { font style ptsize } -- font )
#! Open a font and set the point size of the font.
first3 >r open-face dup 0 r> 6 shift
dpi dpi FT_Set_Char_Size freetype-error <font> ;
-: lookup-font ( @{ font style ptsize }@ -- font )
+: lookup-font ( { font style ptsize } -- font )
#! Cache open fonts.
open-fonts get [ open-font ] cache ;
USING: alien io kernel parser sequences ;
-"freetype" @{
- @{ [ os "macosx" = ] [ "libfreetype.dylib" ] }@
- @{ [ os "win32" = ] [ "freetype6.dll" ] }@
- @{ [ t ] [ "libfreetype.so" ] }@
-}@ cond "cdecl" add-library
+"freetype" {
+ { [ os "macosx" = ] [ "libfreetype.dylib" ] }
+ { [ os "win32" = ] [ "freetype6.dll" ] }
+ { [ t ] [ "libfreetype.so" ] }
+} cond "cdecl" add-library
[
"/library/freetype/freetype.factor"
: class< ( cls1 cls2 -- ? )
#! Test if class1 is a subclass of class2.
- @{
- @{ [ 2dup eq? ] [ 2drop t ] }@
- @{ [ over flatten hash-size 0 = ] [ 2drop t ] }@
- @{ [ over superclass ] [ >r superclass r> class< ] }@
- @{ [ dup superclass ] [ superclass< ] }@
- @{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }@
- @{ [ t ] [ (class<) ] }@
- }@ cond ;
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ over flatten hash-size 0 = ] [ 2drop t ] }
+ { [ over superclass ] [ >r superclass r> class< ] }
+ { [ dup superclass ] [ superclass< ] }
+ { [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
+ { [ t ] [ (class<) ] }
+ } cond ;
: class-compare ( cls1 cls2 -- -1/0/1 )
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
: init-methods ( word -- )
dup "methods" word-prop
- [ drop ] [ {{ }} clone "methods" set-word-prop ] if ;
+ [ drop ] [ H{ } clone "methods" set-word-prop ] if ;
! Defining generic words
: class-and ( class class -- class )
#! Return a class that is a subclass of both, or null in
#! the degenerate case.
- @{
- @{ [ 2dup class< ] [ drop ] }@
- @{ [ 2dup swap class< ] [ nip ] }@
- @{ [ t ] [ (class-and) ] }@
- }@ cond ;
+ {
+ { [ 2dup class< ] [ drop ] }
+ { [ 2dup swap class< ] [ nip ] }
+ { [ t ] [ (class-and) ] }
+ } cond ;
: classes-intersect? ( class class -- ? )
class-and flatten hash-size 0 > ;
: math-vtable ( picker quot -- )
[
swap , \ tag ,
- [ num-tags swap map % ] @{ }@ make ,
+ [ num-tags swap map % ] { } make ,
\ dispatch ,
] [ ] make ; inline
: define-slot ( class slot reader writer -- )
>r >r 2dup r> define-reader r> define-writer ;
-: ?create ( @{ name vocab }@ -- word )
+: ?create ( { name vocab } -- word )
dup [ first2 create ] when ;
: intern-slots ( spec -- spec )
r> 2drop
] if ;
-: delegate-slots @{ @{ 3 delegate set-delegate }@ }@ ;
+: delegate-slots { { 3 delegate set-delegate } } ;
: tuple-slots ( tuple slots -- )
2dup "slot-names" set-word-prop
gadgets-presentations gadgets-theme generic kernel lists math\r
namespaces sdl sequences strings styles ;\r
\r
-: tutorial-font @{ "Serif" plain 14 }@ swap set-label-font ;\r
+: tutorial-font { "Serif" plain 14 } swap set-label-font ;\r
\r
-: heading-font @{ "Serif" plain 24 }@ swap set-label-font ;\r
+: heading-font { "Serif" plain 24 } swap set-label-font ;\r
\r
: <slide-title> ( text -- gadget )\r
<label> dup heading-font ;\r
\r
: <underline> ( -- gadget )\r
<gadget>\r
- << gradient f @{ @{ 0.25 0.25 0.25 1.0 }@ @{ 1.0 1.0 1.0 1.0 }@ }@ >>\r
+ T{ gradient f { { 0.25 0.25 0.25 1.0 } { 1.0 1.0 1.0 1.0 } } }\r
over set-gadget-interior\r
- @{ 0 10 0 }@ over set-gadget-dim\r
- @{ 1 0 0 }@ over set-gadget-orientation ;\r
+ { 0 10 0 } over set-gadget-dim\r
+ { 1 0 0 } over set-gadget-orientation ;\r
\r
GENERIC: tutorial-line ( object -- gadget )\r
\r
M: string tutorial-line\r
- @{\r
- @{ [ "* " ?head ] [ <slide-title> ] }@\r
- @{ [ dup "--" = ] [ drop <underline> ] }@\r
- @{ [ t ] [ <label> dup tutorial-font ] }@\r
- }@ cond ;\r
+ {\r
+ { [ "* " ?head ] [ <slide-title> ] }\r
+ { [ dup "--" = ] [ drop <underline> ] }\r
+ { [ t ] [ <label> dup tutorial-font ] }\r
+ } cond ;\r
\r
: example-theme\r
- << solid f @{ 0.8 0.8 1.0 1.0 }@ >> swap set-gadget-interior ;\r
+ T{ solid f { 0.8 0.8 1.0 1.0 } } swap set-gadget-interior ;\r
\r
M: general-list tutorial-line\r
car <input-button> dup example-theme ;\r
\r
: page-theme\r
- << gradient f @{ @{ 0.8 0.8 1.0 1.0 }@ @{ 1.0 0.8 1.0 1.0 }@ }@ >>\r
+ T{ gradient f { { 0.8 0.8 1.0 1.0 } { 1.0 0.8 1.0 1.0 } } }\r
swap set-gadget-interior ;\r
\r
: <page> ( list -- gadget )\r
dup page-theme <border> ;\r
\r
: tutorial-pages\r
- @{\r
- @{\r
+ {\r
+ {\r
"* Factor: a dynamic language"\r
"--"\r
"This series of slides presents a quick overview of Factor."\r
"You can then press ENTER to execute the code, or edit it first."\r
""\r
"http://factor.sourceforge.net"\r
- }@ @{\r
+ } {\r
"* The view from 10,000 feet"\r
"--"\r
"- Everything is an object"\r
"- Words pass parameters on the stack"\r
"- Code blocks can be passed as parameters to words"\r
"- Word definitions are very short with very high code reuse"\r
- }@ @{\r
+ } {\r
"* Basic syntax"\r
"--"\r
"Factor code is made up of whitespace-speparated tokens."\r
"The first token (\"hello world\") is a string."\r
"The second token (print) is a word."\r
"The string is pushed on the stack, and the print word prints it."\r
- }@ @{\r
+ } {\r
"* The stack"\r
"--"\r
"- The stack is like a pile of papers."\r
[ "2 3 + ." ]\r
""\r
"Try running it in the listener now."\r
- }@ @{\r
+ } {\r
"* Postfix arithmetic"\r
"--"\r
"What happened when you ran it?"\r
"This is called postfix arithmetic."\r
"Traditional arithmetic is called infix: 3 + (6 * 2)"\r
"Lets translate this into postfix: 3 6 2 * + ."\r
- }@ @{\r
+ } {\r
"* Colon definitions"\r
"--"\r
"We can define new words in terms of existing words."\r
"The result is the same as if you wrote:"\r
""\r
[ "3 2 * 2 * ." ]\r
- }@ @{\r
+ } {\r
"* Stack effects"\r
"--"\r
"When we look at the definition of the ``twice'' word,"\r
"The stack effect of twice is ( x -- 2*x )."\r
"The stack effect of + is ( x y -- x+y )."\r
"The stack effect of . is ( object -- )."\r
- }@ @{\r
+ } {\r
"* Reading user input"\r
"--"\r
"User input is read using the readln ( -- string ) word."\r
""\r
[ "\"What is your name?\" print" ]\r
[ "readln \"Hello, \" write print" ]\r
- }@ @{\r
+ } {\r
"* Shuffle words"\r
"--"\r
"The word ``twice'' we defined is useless."\r
"However, we can use the word ``dup''. It has stack effect"\r
"( object -- object object ), and it does exactly what we"\r
"need. The ``dup'' word is known as a shuffle word."\r
- }@ @{\r
+ } {\r
"* The squared word"\r
"--"\r
"Try entering the following word definition:"\r
"drop ( object -- )"\r
"swap ( obj1 obj2 -- obj2 obj1 )"\r
"over ( obj1 obj2 -- obj1 obj2 obj1 )"\r
- }@ @{\r
+ } {\r
"* Another shuffle example"\r
"--"\r
"Now let us write a word that negates a number."\r
"So indeed, we can factor out the definition ``0 swap -'':"\r
""\r
[ ": negate ( n -- -n ) 0 swap - ;" ]\r
- }@ @{\r
+ } {\r
"* Seeing words"\r
"--"\r
"If you have entered every definition in this tutorial,"\r
""\r
"Prefixing a word with \\ pushes it on the stack, instead of"\r
"executing it. So the see word has stack effect ( word -- )."\r
- }@ @{\r
+ } {\r
"* Branches"\r
"--"\r
"Now suppose we want to write a word that computes the"\r
"In Factor, any object can be used as a truth value."\r
"- The f object is false."\r
"- Anything else is true."\r
- }@ @{\r
+ } {\r
"* More branches"\r
"--"\r
"On the previous slide, you saw the 'when' conditional:"\r
"The 'if' conditional takes action on both branches:"\r
""\r
[ " ... condition ... [ ... ] [ ... ] if" ]\r
- }@ @{\r
+ } {\r
"* Combinators"\r
"--"\r
"if, when, unless are words that take lists of code as input."\r
"Try this:"\r
""\r
[ "10 [ \"Hello combinators\" print ] times" ]\r
- }@ @{\r
+ } {\r
"* Sequences"\r
"--"\r
"You have already seen strings, very briefly:"\r
"Two other types of sequences you will use a lot are:"\r
""\r
" Lists: [ 1 3 \"hi\" 10 2 ]"\r
- " Vectors: { \"the\" { \"quick\" \"brown\" } \"fox\" }"\r
+ " Arrays: { \"the\" { \"quick\" \"brown\" } \"fox\" }"\r
""\r
- "As you can see in the second example, lists and vectors"\r
+ "As you can see in the second example, lists and arrays"\r
"can contain any type of object, including other lists"\r
- "and vectors."\r
- }@ @{\r
+ "and arrays."\r
+ } {\r
"* Sequences and combinators"\r
"--"\r
"A very useful combinator is each ( seq quot -- )."\r
""\r
[ "{ 10 20 30 } [ 3 + ] map ." ]\r
"==> { 13 23 33 }"\r
- }@ @{\r
+ } {\r
"* Numbers - integers and ratios"\r
"--"\r
"Factor's supports arbitrary-precision integers and ratios."\r
""\r
"Rational numbers are added, multiplied and reduced to"\r
"lowest terms in the same way you learned in grade school."\r
- }@ @{\r
+ } {\r
"* Object oriented programming"\r
"--"\r
"Each object belongs to a class."\r
"Method definitions may appear in independent source files."\r
""\r
"integer, string, object are built-in classes."\r
- }@ @{\r
+ } {\r
"* Defining new classes"\r
"--"\r
"New classes can be defined:"\r
""\r
"Tuples support custom constructors, delegation..."\r
"see the developer's handbook for details."\r
- }@ @{\r
+ } {\r
"* The library"\r
"--"\r
"Offers a good selection of highly-reusable words:"\r
[ "\"sequences\" words ." ]\r
"- To show a word definition:"\r
[ "\\ reverse see" ]\r
- }@ @{\r
+ } {\r
"* Learning more"\r
"--"\r
"Hopefully this tutorial has sparked your interest in Factor."\r
""\r
"Also, point your IRC client to irc.freenode.net and hop in the"\r
"#concatenative channel to chat with other Factor geeks."\r
- }@\r
- }@ ;\r
+ }\r
+ } ;\r
\r
: <tutorial> ( pages -- browser )\r
tutorial-pages [ <page> ] map <book> <book-browser> ;\r
0 [ [ max ] when* ] reduce ;
: unbalanced-branches ( in out -- )
- @{ "Unbalanced branches:" }@ -rot [
+ { "Unbalanced branches:" } -rot [
swap number>string " " rot length number>string
append3
] 2map append "\n" join inference-error ;
dup optimizer-hooks cond ;
: define-optimizers ( word optimizers -- )
- @{ [ t ] [ drop t ] }@ add "optimizer-hooks" set-word-prop ;
+ { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
dup flip-subst node-successor dup
dup node-children first2 swap 2array swap set-node-children ;
-\ not @{
- @{ [ dup node-successor #if? ] [ flip-branches ] }@
-}@ define-optimizers
+\ not {
+ { [ dup node-successor #if? ] [ flip-branches ] }
+} define-optimizers
: disjoint-eq? ( node -- ? )
dup node-classes swap node-in-d
[ swap ?hash ] map-with
first2 2dup and [ classes-intersect? not ] [ 2drop f ] if ;
-\ eq? @{
- @{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }@
-}@ define-optimizers
+\ eq? {
+ { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
+} define-optimizers
! Arithmetic identities
SYMBOL: @
3drop f
] if ;
-[ + fixnum+ bignum+ float+ ] @{
- @{ @{ @ 0 }@ [ drop ] }@
- @{ @{ 0 @ }@ [ nip ] }@
-}@ define-identities
-
-[ - fixnum- bignum- float- ] @{
- @{ @{ @ 0 }@ [ drop ] }@
- @{ @{ @ @ }@ [ 2drop 0 ] }@
-}@ define-identities
-
-[ * fixnum* bignum* float* ] @{
- @{ @{ @ 1 }@ [ drop ] }@
- @{ @{ 1 @ }@ [ nip ] }@
- @{ @{ @ 0 }@ [ nip ] }@
- @{ @{ 0 @ }@ [ drop ] }@
- @{ @{ @ -1 }@ [ drop 0 swap - ] }@
- @{ @{ -1 @ }@ [ nip 0 swap - ] }@
-}@ define-identities
-
-[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] @{
- @{ @{ @ 1 }@ [ drop ] }@
- @{ @{ @ -1 }@ [ drop 0 swap - ] }@
-}@ define-identities
-
-[ rem mod fixnum-mod bignum-mod ] @{
- @{ @{ @ 1 }@ [ 2drop 0 ] }@
-}@ define-identities
-
-! [ ^ ] @{
-! @{ @{ 1 @ }@ [ 2drop 1 ] }@
-! @{ @{ @ 1 }@ [ drop ] }@
-! @{ @{ @ 2 }@ [ drop dup * ] }@
-! @{ @{ @ -1 }@ [ drop 1 swap / ] }@
-! @{ @{ @ -2 }@ [ drop dup * 1 swap / ] }@
-! }@ define-identities
-
-[ bitand fixnum-bitand bignum-bitand ] @{
- @{ @{ @ -1 }@ [ drop ] }@
- @{ @{ -1 @ }@ [ nip ] }@
- @{ @{ @ @ }@ [ drop ] }@
- @{ @{ @ 0 }@ [ nip ] }@
- @{ @{ 0 @ }@ [ drop ] }@
-}@ define-identities
-
-[ bitor fixnum-bitor bignum-bitor ] @{
- @{ @{ @ 0 }@ [ drop ] }@
- @{ @{ 0 @ }@ [ nip ] }@
- @{ @{ @ @ }@ [ drop ] }@
- @{ @{ @ -1 }@ [ nip ] }@
- @{ @{ -1 @ }@ [ drop ] }@
-}@ define-identities
-
-[ bitxor fixnum-bitxor bignum-bitxor ] @{
- @{ @{ @ 0 }@ [ drop ] }@
- @{ @{ 0 @ }@ [ nip ] }@
- @{ @{ @ -1 }@ [ drop bitnot ] }@
- @{ @{ -1 @ }@ [ nip bitnot ] }@
- @{ @{ @ @ }@ [ 2drop 0 ] }@
-}@ define-identities
-
-[ shift fixnum-shift bignum-shift ] @{
- @{ @{ 0 @ }@ [ drop ] }@
- @{ @{ @ 0 }@ [ drop ] }@
-}@ define-identities
-
-[ < fixnum< bignum< float< ] @{
- @{ @{ @ @ }@ [ 2drop f ] }@
-}@ define-identities
-
-[ <= fixnum<= bignum<= float<= ] @{
- @{ @{ @ @ }@ [ 2drop t ] }@
-}@ define-identities
+[ + fixnum+ bignum+ float+ ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+} define-identities
+
+[ - fixnum- bignum- float- ] {
+ { { @ 0 } [ drop ] }
+ { { @ @ } [ 2drop 0 ] }
+} define-identities
+
+[ * fixnum* bignum* float* ] {
+ { { @ 1 } [ drop ] }
+ { { 1 @ } [ nip ] }
+ { { @ 0 } [ nip ] }
+ { { 0 @ } [ drop ] }
+ { { @ -1 } [ drop 0 swap - ] }
+ { { -1 @ } [ nip 0 swap - ] }
+} define-identities
+
+[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
+ { { @ 1 } [ drop ] }
+ { { @ -1 } [ drop 0 swap - ] }
+} define-identities
+
+[ rem mod fixnum-mod bignum-mod ] {
+ { { @ 1 } [ 2drop 0 ] }
+} define-identities
+
+! [ ^ ] {
+! { { 1 @ } [ 2drop 1 ] }
+! { { @ 1 } [ drop ] }
+! { { @ 2 } [ drop dup * ] }
+! { { @ -1 } [ drop 1 swap / ] }
+! { { @ -2 } [ drop dup * 1 swap / ] }
+! } define-identities
+
+[ bitand fixnum-bitand bignum-bitand ] {
+ { { @ -1 } [ drop ] }
+ { { -1 @ } [ nip ] }
+ { { @ @ } [ drop ] }
+ { { @ 0 } [ nip ] }
+ { { 0 @ } [ drop ] }
+} define-identities
+
+[ bitor fixnum-bitor bignum-bitor ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+ { { @ @ } [ drop ] }
+ { { @ -1 } [ nip ] }
+ { { -1 @ } [ drop ] }
+} define-identities
+
+[ bitxor fixnum-bitxor bignum-bitxor ] {
+ { { @ 0 } [ drop ] }
+ { { 0 @ } [ nip ] }
+ { { @ -1 } [ drop bitnot ] }
+ { { -1 @ } [ nip bitnot ] }
+ { { @ @ } [ 2drop 0 ] }
+} define-identities
+
+[ shift fixnum-shift bignum-shift ] {
+ { { 0 @ } [ drop ] }
+ { { @ 0 } [ drop ] }
+} define-identities
+
+[ < fixnum< bignum< float< ] {
+ { { @ @ } [ 2drop f ] }
+} define-identities
+
+[ <= fixnum<= bignum<= float<= ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
-[ > fixnum> bignum> float>= ] @{
- @{ @{ @ @ }@ [ 2drop f ] }@
-}@ define-identities
+[ > fixnum> bignum> float>= ] {
+ { { @ @ } [ 2drop f ] }
+} define-identities
-[ >= fixnum>= bignum>= float>= ] @{
- @{ @{ @ @ }@ [ 2drop t ] }@
-}@ define-identities
+[ >= fixnum>= bignum>= float>= ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
-[ eq? number= = ] @{
- @{ @{ @ @ }@ [ 2drop t ] }@
-}@ define-identities
+[ eq? number= = ] {
+ { { @ @ } [ 2drop t ] }
+} define-identities
M: #call optimize-node* ( node -- node/t )
- @{
- @{ [ dup partial-eval? ] [ partial-eval ] }@
- @{ [ dup find-identity nip ] [ apply-identities ] }@
- @{ [ dup optimizer-hooks ] [ optimize-hooks ] }@
- @{ [ dup inlining-class ] [ inline-method ] }@
- @{ [ dup optimize-predicate? ] [ optimize-predicate ] }@
- @{ [ t ] [ drop t ] }@
- }@ cond ;
+ {
+ { [ dup partial-eval? ] [ partial-eval ] }
+ { [ dup find-identity nip ] [ apply-identities ] }
+ { [ dup optimizer-hooks ] [ optimize-hooks ] }
+ { [ dup inlining-class ] [ inline-method ] }
+ { [ dup optimize-predicate? ] [ optimize-predicate ] }
+ { [ t ] [ drop t ] }
+ } cond ;
: infer-classes ( node -- )
[
- {{ }} clone value-classes set
- {{ }} clone value-literals set
- {{ }} clone ties set
+ H{ } clone value-classes set
+ H{ } clone value-literals set
+ H{ } clone ties set
(infer-classes)
] with-scope ;
: set-node-out-d node-shuffle set-shuffle-out-d ;
: set-node-out-r node-shuffle set-shuffle-out-r ;
-: empty-node f @{ }@ @{ }@ @{ }@ @{ }@ ;
-: param-node ( label) @{ }@ @{ }@ @{ }@ @{ }@ ;
-: in-node ( inputs) >r f r> @{ }@ @{ }@ @{ }@ ;
-: out-node ( outputs) >r f @{ }@ r> @{ }@ @{ }@ ;
+: empty-node f { } { } { } { } ;
+: param-node ( label) { } { } { } { } ;
+: in-node ( inputs) >r f r> { } { } { } ;
+: out-node ( outputs) >r f { } r> { } { } ;
: d-tail ( n -- list ) meta-d get tail* ;
: r-tail ( n -- list ) meta-r get tail* ;
[
dup node-in-d % dup node-out-d %
dup node-in-r % node-out-r %
- ] @{ }@ make ;
+ ] { } make ;
: uses-value? ( value node -- ? ) node-values memq? ;
inference-error-rstate describe ;
M: value literal-value ( value -- )
- @{
+ {
"A literal value was expected where a computed value was found.\n"
"This means the word you are inferring applies 'call' or 'execute'\n"
"to a value that is not known at compile time.\n"
"See the handbook for details."
- }@ concat inference-error ;
+ } concat inference-error ;
! Word properties that affect inference:
! - infer-effect -- must be set. controls number of inputs
dup meta-d get required-inputs d-in [ + ] change
meta-d [ add-inputs ] change ;
-: effect ( -- @{ in# out# }@ )
+: effect ( -- { in# out# } )
#! After inference is finished, collect information.
d-in get meta-d get length 2array ;
: init-inference ( recursive-state -- )
terminated? off
- { } clone meta-r set
- { } clone meta-d set
+ V{ } clone meta-r set
+ V{ } clone meta-d set
0 d-in set
recursive-state set
dataflow-graph off
GENERIC: dispatching-values ( node word -- seq )
-M: object dispatching-values 2drop @{ }@ ;
+M: object dispatching-values 2drop { } ;
M: simple-generic dispatching-values drop node-in-d peek 1array ;
: returns ( node -- seq )
#! Trace all control flow paths, build a hash of
#! final #return nodes.
- [ returns* ] @{ }@ make ;
+ [ returns* ] { } make ;
M: f returns* drop ;
[ [ remove-values ] each-node-with ] [ 2drop ] if ;
! Generic nodes
-M: node literals* ( node -- ) drop @{ }@ ;
+M: node literals* ( node -- ) drop { } ;
M: node live-values* ( node -- ) node-values ;
M: #return live-values* ( node -- seq )
#! Values returned by local labels can be killed.
- dup node-param [ drop @{ }@ ] [ delegate live-values* ] if ;
+ dup node-param [ drop { } ] [ delegate live-values* ] if ;
! nodes that don't use their input values directly
UNION: #killable #shuffle #call-label #merge #values ;
-M: #killable live-values* ( node -- seq ) drop @{ }@ ;
+M: #killable live-values* ( node -- seq ) drop { } ;
! #entry
M: #entry live-values* ( node -- seq )
dup "infer-effect" word-prop consume/produce
[ [ t ] [ f ] if ] infer-quot ;
-@{ fixnum<= fixnum< fixnum>= fixnum> eq? }@ [
+{ fixnum<= fixnum< fixnum>= fixnum> eq? } [
dup dup literalize [ manual-branch ] cons
"infer" set-word-prop
] each
#! Collect the input stacks of all #call-label nodes that
#! call given label.
dup node-param swap
- [ [ collect-recursion* ] each-node-with ] @{ }@ make ;
+ [ [ collect-recursion* ] each-node-with ] { } make ;
GENERIC: solve-recursion*
TUPLE: shuffle in-d in-r out-d out-r ;
-: empty-shuffle @{ }@ @{ }@ @{ }@ @{ }@ <shuffle> ;
+: empty-shuffle { } { } { } { } <shuffle> ;
: cut* ( seq1 seq2 -- seq seq ) [ head* ] 2keep tail* ;
[ shuffle>effect "infer-effect" set-word-prop ] 2keep
[ , \ infer-shuffle , ] [ ] make "infer" set-word-prop ;
-@{
- @{ drop << shuffle f 1 0 @{ }@ @{ }@ >> }@
- @{ 2drop << shuffle f 2 0 @{ }@ @{ }@ >> }@
- @{ 3drop << shuffle f 3 0 @{ }@ @{ }@ >> }@
- @{ dup << shuffle f 1 0 @{ 0 0 }@ @{ }@ >> }@
- @{ 2dup << shuffle f 2 0 @{ 0 1 0 1 }@ @{ }@ >> }@
- @{ 3dup << shuffle f 3 0 @{ 0 1 2 0 1 2 }@ @{ }@ >> }@
- @{ rot << shuffle f 3 0 @{ 1 2 0 }@ @{ }@ >> }@
- @{ -rot << shuffle f 3 0 @{ 2 0 1 }@ @{ }@ >> }@
- @{ dupd << shuffle f 2 0 @{ 0 0 1 }@ @{ }@ >> }@
- @{ swapd << shuffle f 3 0 @{ 1 0 2 }@ @{ }@ >> }@
- @{ nip << shuffle f 2 0 @{ 1 }@ @{ }@ >> }@
- @{ 2nip << shuffle f 3 0 @{ 2 }@ @{ }@ >> }@
- @{ tuck << shuffle f 2 0 @{ 1 0 1 }@ @{ }@ >> }@
- @{ over << shuffle f 2 0 @{ 0 1 0 }@ @{ }@ >> }@
- @{ pick << shuffle f 3 0 @{ 0 1 2 0 }@ @{ }@ >> }@
- @{ swap << shuffle f 2 0 @{ 1 0 }@ @{ }@ >> }@
- @{ >r << shuffle f 1 0 @{ }@ @{ 0 }@ >> }@
- @{ r> << shuffle f 0 1 @{ 0 }@ @{ }@ >> }@
-}@ [ first2 define-shuffle ] each
+{
+ { drop T{ shuffle f 1 0 { } { } } }
+ { 2drop T{ shuffle f 2 0 { } { } } }
+ { 3drop T{ shuffle f 3 0 { } { } } }
+ { dup T{ shuffle f 1 0 { 0 0 } { } } }
+ { 2dup T{ shuffle f 2 0 { 0 1 0 1 } { } } }
+ { 3dup T{ shuffle f 3 0 { 0 1 2 0 1 2 } { } } }
+ { rot T{ shuffle f 3 0 { 1 2 0 } { } } }
+ { -rot T{ shuffle f 3 0 { 2 0 1 } { } } }
+ { dupd T{ shuffle f 2 0 { 0 0 1 } { } } }
+ { swapd T{ shuffle f 3 0 { 1 0 2 } { } } }
+ { nip T{ shuffle f 2 0 { 1 } { } } }
+ { 2nip T{ shuffle f 3 0 { 2 } { } } }
+ { tuck T{ shuffle f 2 0 { 1 0 1 } { } } }
+ { over T{ shuffle f 2 0 { 0 1 0 } { } } }
+ { pick T{ shuffle f 3 0 { 0 1 2 0 } { } } }
+ { swap T{ shuffle f 2 0 { 1 0 } { } } }
+ { >r T{ shuffle f 1 0 { } { 0 } } }
+ { r> T{ shuffle f 0 1 { 0 } { } } }
+} [ first2 define-shuffle ] each
[ inferring-base-case off ] cleanup ;
: no-base-case ( word -- )
- @{
+ {
"The base case of a recursive word could not be inferred.\n"
"This means the word calls itself in every control flow path.\n"
"See the handbook for details."
- }@ concat inference-error ;
+ } concat inference-error ;
: notify-base-case ( -- )
base-case-continuation get
: directory ( dir -- list )
(directory)
- {{ [[ "." "." ]] [[ ".." ".." ]] }}
+ H{ [[ "." "." ]] [[ ".." ".." ]] }
swap remove-all string-sort ;
: file-length ( file -- length ) stat third ;
: lines ( stream -- seq )
#! Read all lines from the stream into a sequence.
- [ { } clone (lines) ] with-stream ;
+ [ V{ } clone (lines) ] with-stream ;
#! Clear the datastack. For interactive use only; invoking
#! this from a word definition will clobber any values left
#! on the data stack by the caller.
- { } set-datastack ;
+ V{ } set-datastack ;
GENERIC: hashcode ( obj -- n ) flushable
M: object hashcode drop 0 ;
! See http://factor.sf.net/license.txt for BSD license.
IN: math
-: i #{ 0 1 }# ; inline
-: -i #{ 0 -1 }# ; inline
+: i C{ 0 1 } ; inline
+: -i C{ 0 -1 } ; inline
: inf 1.0 0.0 / ; inline
: -inf -1.0 0.0 / ; inline
: e 2.7182818284590452354 ; inline
"/" split1 [ 10 base> ] 2apply / ;
: string>number ( string -- n )
- @{
- @{ [ CHAR: / over member? ] [ string>ratio ] }@
- @{ [ CHAR: . over member? ] [ string>float ] }@
- @{ [ t ] [ 10 base> ] }@
- }@ cond ;
+ {
+ { [ CHAR: / over member? ] [ string>ratio ] }
+ { [ CHAR: . over member? ] [ string>float ] }
+ { [ t ] [ 10 base> ] }
+ } cond ;
: bin> 2 base> ;
: oct> 8 base> ;
USING: alien io kernel parser sequences ;
-@{
- @{ [ os "macosx" = ] [ ] }@
- @{ [ os "win32" = ] [
+{
+ { [ os "macosx" = ] [ ] }
+ { [ os "win32" = ] [
"gl" "opengl32.dll" "stdcall" add-library
"glu" "glu32.dll" "stdcall" add-library
- ] }@
- @{ [ t ] [
+ ] }
+ { [ t ] [
"gl" "libGL.so" "cdecl" add-library
"glu" "libGLU.so" "cdecl" add-library
- ] }@
-}@ cond
+ ] }
+} cond
[
"/library/opengl/gl.factor"
IN: opengl
USING: alien errors kernel math namespaces opengl sdl sequences ;
-: gl-color ( @{ r g b a }@ -- ) first4 glColor4d ; inline
+: gl-color ( { r g b a } -- ) first4 glColor4d ; inline
: init-gl ( -- )
0.0 0.0 0.0 0.0 glClearColor
- @{ 1.0 0.0 0.0 0.0 }@ gl-color
+ { 1.0 0.0 0.0 0.0 } gl-color
GL_COLOR_BUFFER_BIT glClear
GL_PROJECTION glMatrixMode
glLoadIdentity
: gl-vertex first3 glVertex3d ; inline
-: top-left drop 0 0 glTexCoord2d @{ 0 0 0 }@ gl-vertex ; inline
+: top-left drop 0 0 glTexCoord2d { 0 0 0 } gl-vertex ; inline
-: top-right 1 0 glTexCoord2d @{ 1 0 0 }@ v* gl-vertex ; inline
+: top-right 1 0 glTexCoord2d { 1 0 0 } v* gl-vertex ; inline
-: bottom-left 0 1 glTexCoord2d @{ 0 1 0 }@ v* gl-vertex ; inline
+: bottom-left 0 1 glTexCoord2d { 0 1 0 } v* gl-vertex ; inline
: bottom-right 1 1 glTexCoord2d gl-vertex ; inline
: gl-rect ( dim -- )
#! Draws a two-dimensional box.
GL_MODELVIEW [
- 0.5 0.5 0 glTranslatef @{ 1 1 0 }@ v-
+ 0.5 0.5 0 glTranslatef { 1 1 0 } v-
GL_LINE_STRIP [ dup four-sides top-left ] do-state
] do-matrix ;
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
-: gl-translate ( @{ x y z }@ -- ) first3 glTranslatef ;
+: gl-translate ( { x y z } -- ) first3 glTranslatef ;
: make-sprite-dlist ( sprite -- id )
GL_MODELVIEW [
GL_TEXTURE_2D over sprite-texture glBindTexture
init-texture
dup sprite-dim2 gl-fill-rect
- dup sprite-dim @{ 1 0 0 }@ v*
+ dup sprite-dim { 1 0 0 } v*
swap sprite-loc v- gl-translate
] make-dlist
] do-matrix ;
USING: alien io kernel parser sequences ;
-@{
- @{ [ os "macosx" = ] [ ] }@
- @{ [ os "win32" = ] [ "sdl" "sdl.dll" "cdecl" add-library ] }@
- @{ [ t ] [ "sdl" "libSDL.so" "cdecl" add-library ] }@
-}@ cond
+{
+ { [ os "macosx" = ] [ ] }
+ { [ os "win32" = ] [ "sdl" "sdl.dll" "cdecl" add-library ] }
+ { [ t ] [ "sdl" "libSDL.so" "cdecl" add-library ] }
+} cond
[
"/library/sdl/sdl.factor"
! Later, something better needs to be done.
: modifiers
- @{
+ {
[[ "SHIFT" HEX: 0003 ]]
[[ "CTRL" HEX: 00c0 ]]
[[ "ALT" HEX: 0300 ]]
[[ "META" HEX: 0c00 ]]
- }@ ;
+ } ;
: keysyms
- {{
+ H{
! The keyboard syms have been cleverly chosen to map to ASCII
[[ 0 "UNKNOWN" ]]
[[ 8 "BACKSPACE" ]]
[[ 321 "EURO" ]] ! Some european keyboards
[[ 322 "UNDO" ]] ! Atari keyboard has Undo
! Add any other keys here
- }} ;
+ } ;
IN: styles
! Colors are RGBA quadruples
-: black @{ 0.0 0.0 0.0 1.0 }@ ;
-: dark-gray @{ 0.25 0.25 0.25 1.0 }@ ;
-: gray @{ 0.5 0.5 0.5 1.0 }@ ;
-: light-gray @{ 0.75 0.75 0.75 1.0 }@ ;
-: white @{ 1.0 1.0 1.0 1.0 }@ ;
-: red @{ 1.0 0.0 0.0 1.0 }@ ;
-: green @{ 0.0 1.0 0.0 1.0 }@ ;
-: blue @{ 0.0 0.0 1.0 1.0 }@ ;
+: black { 0.0 0.0 0.0 1.0 } ;
+: dark-gray { 0.25 0.25 0.25 1.0 } ;
+: gray { 0.5 0.5 0.5 1.0 } ;
+: light-gray { 0.75 0.75 0.75 1.0 } ;
+: white { 1.0 1.0 1.0 1.0 } ;
+: red { 1.0 0.0 0.0 1.0 } ;
+: green { 0.0 1.0 0.0 1.0 } ;
+: blue { 0.0 0.0 1.0 1.0 } ;
SYMBOL: foreground ! Used for text and outline shapes.
SYMBOL: background ! Used for filled shapes.
#! stack.
scan-word [ tuple-constructor ] keep
[ define-constructor ] [ ] ; parsing
-
-! Tuples.
-: << f ; parsing
-: >> reverse array>tuple swons ; parsing
: [[ f ; parsing
: ]] first2 swons swons ; parsing
-! Arrays
-: @{ f ; parsing
-: }@ reverse >array swons ; parsing
+! Arrays, vectors, etc
+: } reverse swap call swons ; parsing
-! Vectors
-: { f ; parsing
-: } reverse >vector swons ; parsing
-
-! Hashtables
-: {{ f ; parsing
-: }} alist>hash swons ; parsing
+: { ( array ) [ >array ] [ ] ; parsing
+: V{ ( vector ) [ >vector ] [ ] ; parsing
+: H{ ( hashtable ) [ alist>hash ] [ ] ; parsing
+: C{ ( complex ) [ first2 rect> ] [ ] ; parsing
+: T{ ( tuple ) [ array>tuple ] [ ] ; parsing
+: W{ ( wrapper ) [ first <wrapper> ] [ ] ; parsing
! Do not execute parsing word
: POSTPONE: ( -- ) scan-word swons ; parsing
#! Word literals: \ foo
scan-word literalize swons ; parsing
-! Long wrapper syntax. Only used in the rare case that another
-! wrapper is being wrapped.
-: W[ [ ] ; parsing
-: ]W first <wrapper> swons ; parsing
-
! Vocabularies
: PRIMITIVE:
#! This is just for show. All flash no substance.
#! Documentation comment.
until-eol parsed-documentation ; parsing
-! Complex numbers
-: #{ f ; parsing
-: }# dup second swap first rect> swons ; parsing
-
! Reading integers in other bases
: (BASE) ( base -- )
#! Reads an integer in a specific base.
C: block ( -- block )
0 <section> over set-delegate
- { } clone over set-block-sections
+ V{ } clone over set-block-sections
t over set-section-nl-after?
tab-size get over set-section-indent ;
GENERIC: pprint* ( obj -- )
: vocab-style ( vocab -- style )
- {{
- [[ "syntax" [ [[ foreground @{ 0.5 0.5 0.5 1.0 }@ ]] ] ]]
- [[ "kernel" [ [[ foreground @{ 0.0 0.0 0.5 1.0 }@ ]] ] ]]
- [[ "sequences" [ [[ foreground @{ 0.5 0.0 0.0 1.0 }@ ]] ] ]]
- [[ "math" [ [[ foreground @{ 0.0 0.5 0.0 1.0 }@ ]] ] ]]
- [[ "math-internals" [ [[ foreground @{ 0.75 0.0 0.0 1.0 }@ ]] ] ]]
- [[ "kernel-internals" [ [[ foreground @{ 0.75 0.0 0.0 1.0 }@ ]] ] ]]
- [[ "io-internals" [ [[ foreground @{ 0.75 0.0 0.0 1.0 }@ ]] ] ]]
- }} hash ;
+ H{
+ [[ "syntax" [ [[ foreground { 0.5 0.5 0.5 1.0 } ]] ] ]]
+ [[ "kernel" [ [[ foreground { 0.0 0.0 0.5 1.0 } ]] ] ]]
+ [[ "sequences" [ [[ foreground { 0.5 0.0 0.0 1.0 } ]] ] ]]
+ [[ "math" [ [[ foreground { 0.0 0.5 0.0 1.0 } ]] ] ]]
+ [[ "math-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]]
+ [[ "kernel-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]]
+ [[ "io-internals" [ [[ foreground { 0.75 0.0 0.0 1.0 } ]] ] ]]
+ } hash ;
: word-style ( word -- style )
dup word-vocabulary vocab-style swap presented swons add ;
M: real pprint* ( obj -- ) number>string f text ;
: ch>ascii-escape ( ch -- esc )
- {{
+ H{
[[ CHAR: \e "\\e" ]]
[[ CHAR: \n "\\n" ]]
[[ CHAR: \r "\\r" ]]
[[ CHAR: \0 "\\0" ]]
[[ CHAR: \\ "\\\\" ]]
[[ CHAR: \" "\\\"" ]]
- }} hash ;
+ } hash ;
: ch>unicode-escape ( ch -- esc )
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
swap pprint* swap pprint-elements pprint* ;
M: complex pprint* ( num -- )
- >rect 2array \ #{ \ }# pprint-sequence ;
+ >rect 2array \ C{ \ } pprint-sequence ;
M: cons pprint* ( list -- )
[
] check-recursion ;
M: array pprint* ( vector -- )
- [ \ @{ \ }@ pprint-sequence ] check-recursion ;
+ [ \ { \ } pprint-sequence ] check-recursion ;
M: vector pprint* ( vector -- )
- [ \ { \ } pprint-sequence ] check-recursion ;
+ [ \ V{ \ } pprint-sequence ] check-recursion ;
M: hashtable pprint* ( hashtable -- )
- [ hash>alist \ {{ \ }} pprint-sequence ] check-recursion ;
+ [ hash>alist \ H{ \ } pprint-sequence ] check-recursion ;
M: tuple pprint* ( tuple -- )
[
- \ << pprint*
+ \ T{ pprint*
tuple>array dup first pprint*
<block 1 swap tail-slice pprint-elements block>
- \ >> pprint*
+ \ } pprint*
] check-recursion ;
M: alien pprint* ( alien -- )
dup wrapped word? [
\ \ pprint-word wrapped pprint-word
] [
- wrapped 1array \ W[ \ ]W pprint-sequence
+ wrapped 1array \ W{ \ } pprint-sequence
] if ;
: with-pprint ( quot -- )
: define-open
#! The word will be pretty-printed as a block opener.
- #! Examples are [ { {{ [[ << and so on.
t "pprint-open" set-word-prop ;
: define-close ( word -- )
#! The word will be pretty-printed as a block closer.
- #! Examples are ] } }} ]] >> and so on.
t "pprint-close" set-word-prop ;
-@{
- @{ POSTPONE: [ POSTPONE: ] }@
- @{ POSTPONE: { POSTPONE: } }@
- @{ POSTPONE: @{ POSTPONE: }@ }@
- @{ POSTPONE: {{ POSTPONE: }} }@
- @{ POSTPONE: [[ POSTPONE: ]] }@
- @{ POSTPONE: [[ POSTPONE: ]] }@
-}@ [ first2 define-close define-open ] each
+{
+ POSTPONE: [ POSTPONE: [[
+ POSTPONE: { POSTPONE: V{ POSTPONE: H{
+ POSTPONE: T{ POSTPONE: W{
+} [ define-open ] each
+
+{ POSTPONE: [ POSTPONE: } POSTPONE: ]] }
+[ define-close ] each
swap box-i swap box-i + <box>
] if ; compiled
-[ << box f 9227465 >> ] [ << box f 34 >> tuple-fib ] unit-test
+[ T{ box f 9227465 } ] [ T{ box f 34 } tuple-fib ] unit-test
SYMBOL: n
: namespace-fib ( n -- n )
IN: temporary
USING: arrays kernel sequences sequences-internals test vectors ;
-[ -2 @{ "a" "b" "c" }@ nth ] unit-test-fails
-[ 10 @{ "a" "b" "c" }@ nth ] unit-test-fails
-[ "hi" -2 @{ "a" "b" "c" }@ set-nth ] unit-test-fails
-[ "hi" 10 @{ "a" "b" "c" }@ set-nth ] unit-test-fails
-[ f ] [ @{ "a" "b" "c" }@ dup clone eq? ] unit-test
-[ "hi" ] [ "hi" 1 @{ "a" "b" "c" }@ clone [ set-nth ] keep second ] unit-test
-[ { "a" "b" "c" } ] [ @{ "a" "b" "c" }@ >vector ] unit-test
-[ f ] [ @{ "a" "b" "c" }@ dup >array eq? ] unit-test
-[ t ] [ @{ "a" "b" "c" }@ dup @{ }@ like eq? ] unit-test
-[ t ] [ @{ "a" "b" "c" }@ dup array>vector underlying eq? ] unit-test
-[ { "a" "b" "c" } ] [ @{ "a" "b" "c" }@ array>vector ] unit-test
-[ @{ "a" "b" "c" }@ ] [ @{ "a" }@ @{ "b" "c" }@ append ] unit-test
-[ @{ "a" "b" "c" "d" "e" }@ ]
-[ @{ "a" }@ @{ "b" "c" }@ @{ "d" "e" }@ append3 ] unit-test
+[ -2 { "a" "b" "c" } nth ] unit-test-fails
+[ 10 { "a" "b" "c" } nth ] unit-test-fails
+[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
+[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
+[ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
+[ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
+[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
+[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
+[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
+[ t ] [ { "a" "b" "c" } dup array>vector underlying eq? ] unit-test
+[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } array>vector ] unit-test
+[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
+[ { "a" "b" "c" "d" "e" } ]
+[ { "a" } { "b" "c" } { "d" "e" } append3 ] unit-test
16 <hashtable> "testhash" set
-t #{ 2 3 }# "testhash" get set-hash
+t C{ 2 3 } "testhash" get set-hash
f 100000000000000000000000000 "testhash" get set-hash
{ } { [ { } ] } "testhash" get set-hash
-[ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test
+[ t ] [ C{ 2 3 } "testhash" get hash ] unit-test
[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test
[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test
[ 4 ] [
"hey"
- {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode)
+ H{ [[ "hey" 4 ]] [[ "whey" 5 ]] } 2dup (hashcode)
swap underlying nth assoc
] unit-test
! Testing the hash element counting
-{{ }} clone "counting" set
+H{ } clone "counting" set
"value" "key" "counting" get set-hash
[ 1 ] [ "counting" get hash-size ] unit-test
"value" "key" "counting" get set-hash
"key" "counting" get remove-hash
[ 0 ] [ "counting" get hash-size ] unit-test
-[ t ] [ {{ }} dup hash-contained? ] unit-test
-[ f ] [ {{ [[ 1 3 ]] }} {{ }} hash-contained? ] unit-test
-[ t ] [ {{ }} {{ [[ 1 3 ]] }} hash-contained? ] unit-test
-[ t ] [ {{ [[ 1 3 ]] }} {{ [[ 1 3 ]] }} hash-contained? ] unit-test
-[ f ] [ {{ [[ 1 3 ]] }} {{ [[ 1 "hey" ]] }} hash-contained? ] unit-test
-[ f ] [ {{ [[ 1 f ]] }} {{ }} hash-contained? ] unit-test
-[ t ] [ {{ [[ 1 f ]] }} {{ [[ 1 f ]] }} hash-contained? ] unit-test
-
-[ t ] [ {{ }} dup = ] unit-test
-[ f ] [ "xyz" {{ }} = ] unit-test
-[ t ] [ {{ }} {{ }} = ] unit-test
-[ f ] [ {{ [[ 1 3 ]] }} {{ }} = ] unit-test
-[ f ] [ {{ }} {{ [[ 1 3 ]] }} = ] unit-test
-[ t ] [ {{ [[ 1 3 ]] }} {{ [[ 1 3 ]] }} = ] unit-test
-[ f ] [ {{ [[ 1 3 ]] }} {{ [[ 1 "hey" ]] }} = ] unit-test
+[ t ] [ H{ } dup hash-contained? ] unit-test
+[ f ] [ H{ [[ 1 3 ]] } H{ } hash-contained? ] unit-test
+[ t ] [ H{ } H{ [[ 1 3 ]] } hash-contained? ] unit-test
+[ t ] [ H{ [[ 1 3 ]] } H{ [[ 1 3 ]] } hash-contained? ] unit-test
+[ f ] [ H{ [[ 1 3 ]] } H{ [[ 1 "hey" ]] } hash-contained? ] unit-test
+[ f ] [ H{ [[ 1 f ]] } H{ } hash-contained? ] unit-test
+[ t ] [ H{ [[ 1 f ]] } H{ [[ 1 f ]] } hash-contained? ] unit-test
+
+[ t ] [ H{ } dup = ] unit-test
+[ f ] [ "xyz" H{ } = ] unit-test
+[ t ] [ H{ } H{ } = ] unit-test
+[ f ] [ H{ [[ 1 3 ]] } H{ } = ] unit-test
+[ f ] [ H{ } H{ [[ 1 3 ]] } = ] unit-test
+[ t ] [ H{ [[ 1 3 ]] } H{ [[ 1 3 ]] } = ] unit-test
+[ f ] [ H{ [[ 1 3 ]] } H{ [[ 1 "hey" ]] } = ] unit-test
! Test rehashing
[
3
] [
- 2 {{
+ 2 H{
[[ 1 2 ]]
[[ 2 3 ]]
- }} clone hash
+ } clone hash
] unit-test
! There was an assoc in place of assoc* somewhere
[ 1 ] [ "f-hash-test" get hash-size ] unit-test
[ 21 ] [
- 0 {{
+ 0 H{
[[ 1 2 ]]
[[ 3 4 ]]
[[ 5 6 ]]
- }} [
+ } [
uncons + +
] hash-each
] unit-test
-{{ }} clone "cache-test" set
+H{ } clone "cache-test" set
[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
[
- {{ [[ "factor" "rocks" ]] [[ 3 4 ]] }}
+ H{ [[ "factor" "rocks" ]] [[ 3 4 ]] }
] [
- {{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }}
- {{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }}
+ H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }
+ H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
hash-intersect
] unit-test
[
- {{ [[ 1 2 ]] [[ 2 3 ]] }}
+ H{ [[ 1 2 ]] [[ 2 3 ]] }
] [
- {{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }}
- {{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }}
+ H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }
+ H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
hash-diff
] unit-test
[
2
] [
- {{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }}
- {{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }}
+ H{ [[ "factor" "rocks" ]] [[ "dup" "sq" ]] [[ 3 4 ]] }
+ H{ [[ "factor" "rocks" ]] [[ 1 2 ]] [[ 2 3 ]] [[ 3 4 ]] }
hash-diff hash-size
] unit-test
[
t
] [
- {{ [[ "hello" "world" ]] }}
+ H{ [[ "hello" "world" ]] }
clone
100 [ 1+ over set-bucket-count hashcode ] map-with all-equal?
] unit-test
[
- {{ [[ 1 2 ]] [[ 2 3 ]] [[ 6 5 ]] }}
+ H{ [[ 1 2 ]] [[ 2 3 ]] [[ 6 5 ]] }
] [
- {{ [[ 2 4 ]] [[ 6 5 ]] }} {{ [[ 1 2 ]] [[ 2 3 ]] }}
+ H{ [[ 2 4 ]] [[ 6 5 ]] } H{ [[ 1 2 ]] [[ 2 3 ]] }
hash-union
] unit-test
-[ [ 1 3 ] ] [ {{ [[ 2 2 ]] }} [ 1 2 3 ] remove-all ] unit-test
+[ [ 1 3 ] ] [ H{ [[ 2 2 ]] } [ 1 2 3 ] remove-all ] unit-test
USE: test
USE: words
-{{ }} clone "test-namespace" set
+H{ } clone "test-namespace" set
: test-namespace ( -- )
- {{ }} clone dup [ namespace = ] bind ;
+ H{ } clone dup [ namespace = ] bind ;
[ t ] [ test-namespace ] unit-test
10 "some-global" set
[ f ]
-[ {{ }} clone [ f "some-global" set "some-global" get ] bind ]
+[ H{ } clone [ f "some-global" set "some-global" get ] bind ]
unit-test
[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test
-[ @{ 1 2 3 4 5 }@ ] [ 5 [ drop "queue" get deque ] map ] unit-test
+[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test
[ "queue" get deque ] unit-test-fails
IN: temporary
-USING: kernel lists math namespaces sequences
+USING: arrays kernel lists math namespaces sequences
sequences-internals strings test vectors ;
-[ { 1 2 3 4 } ] [ 1 5 <range> >vector ] unit-test
+[ V{ 1 2 3 4 } ] [ 1 5 <range> >vector ] unit-test
[ 3 ] [ 1 4 <range> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
-[ { 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
-[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test
-[ { 3 4 } ] [ 2 4 1 10 <range> subseq >vector ] unit-test
-[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq >vector ] unit-test
+[ V{ 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
+[ V{ 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test
+[ V{ 3 4 } ] [ 2 4 1 10 <range> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq >vector ] unit-test
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
[ { } ] [ { } flip ] unit-test
-[ @{ "b" "e" }@ ] [ 1 @{ @{ "a" "b" "c" }@ @{ "d" "e" "f" }@ }@ flip nth ] unit-test
+[ { "b" "e" } ] [ 1 { { "a" "b" "c" } { "d" "e" "f" } } flip nth ] unit-test
-[ @{ @{ 1 4 }@ @{ 2 5 }@ @{ 3 6 }@ }@ ]
-[ @{ @{ 1 2 3 }@ @{ 4 5 6 }@ }@ flip ] unit-test
+[ { { 1 4 } { 2 5 } { 3 6 } } ]
+[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
[ { 1 2 3 4 5 6 7 8 9 } ] [
[ - ] { 9 8 7 6 5 4 3 2 1 } clone seq-sorter sort-step
- sorter-seq >vector nip
+ sorter-seq >array nip
] unit-test
[ { 1 2 3 4 5 6 7 8 9 } ] [
[ - ] { 1 2 3 4 5 6 7 8 9 } clone seq-sorter sort-step
- sorter-seq >vector nip
+ sorter-seq >array nip
] unit-test
[ [ ] ] [ [ ] number-sort ] unit-test
] all?
] unit-test
-[ @{ "" "a" "aa" "aaa" }@ ]
+[ { "" "a" "aa" "aaa" } ]
[ 4 [ CHAR: a fill ] map ]
unit-test
-[ { } ] [ "f" { } clone [ delete ] keep ] unit-test
-[ { } ] [ "f" { "f" } clone [ delete ] keep ] unit-test
-[ { } ] [ "f" { "f" "f" } clone [ delete ] keep ] unit-test
-[ { "x" } ] [ "f" { "f" "x" "f" } clone [ delete ] keep ] unit-test
-[ { "y" "x" } ] [ "f" { "y" "f" "x" "f" } clone [ delete ] keep ] unit-test
+[ V{ } ] [ "f" V{ } clone [ delete ] keep ] unit-test
+[ V{ } ] [ "f" V{ "f" } clone [ delete ] keep ] unit-test
+[ V{ } ] [ "f" V{ "f" "f" } clone [ delete ] keep ] unit-test
+[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone [ delete ] keep ] unit-test
+[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone [ delete ] keep ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] inject ] unit-test
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
-[ 5 ] [ 1 >bignum @{ 1 5 7 }@ nth-unsafe ] unit-test
+[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
[ 5 ] [ 1 >bignum "\u0001\u0005\u0007" nth-unsafe ] unit-test
[ "before&after" ] [ "&" 6 11 "before and after" replace-slice ] unit-test
[ -1 ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test
-[ { } { } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test
-[ { "C" } { "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
[ -1 1 "abc" <slice> ] unit-test-fails
-[ { "a" "b" } { } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
[ -1 ] [ "ab" "abc" lexi ] unit-test
[ 1 ] [ "abc" "ab" lexi ] unit-test
-[ 1 4 9 16 16 { f 1 4 9 16 } ] [
- { } clone "cache-test" set
+[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
+ V{ } clone "cache-test" set
1 "cache-test" get [ sq ] cache-nth
2 "cache-test" get [ sq ] cache-nth
3 "cache-test" get [ sq ] cache-nth
[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test
-[ @{ "hell" "o wo" "rld" }@ ] [ 4 "hello world" group ] unit-test
+[ { "hell" "o wo" "rld" } ] [ 4 "hello world" group ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
[ ] [ 10 [ [ -1000000 <vector> ] catch drop ] times ] unit-test
[ 3 ] [ [ t f t ] length ] unit-test
-[ 3 ] [ { t f t } length ] unit-test
+[ 3 ] [ V{ t f t } length ] unit-test
-[ -3 { } nth ] unit-test-fails
-[ 3 { } nth ] unit-test-fails
-[ 3 #{ 1 2 }# nth ] unit-test-fails
+[ -3 V{ } nth ] unit-test-fails
+[ 3 V{ } nth ] unit-test-fails
+[ 3 C{ 1 2 } nth ] unit-test-fails
[ "hey" [ 1 2 ] set-length ] unit-test-fails
-[ "hey" { 1 2 } set-length ] unit-test-fails
+[ "hey" V{ 1 2 } set-length ] unit-test-fails
[ 3 ] [ 3 0 <vector> [ set-length ] keep length ] unit-test
[ "yo" ] [
"yo" 4 1 <vector> [ set-nth ] keep 4 swap nth
] unit-test
-[ 1 { } nth ] unit-test-fails
-[ -1 { } set-length ] unit-test-fails
-[ { } ] [ [ ] >vector ] unit-test
-[ { 1 2 } ] [ [ 1 2 ] >vector ] unit-test
+[ 1 V{ } nth ] unit-test-fails
+[ -1 V{ } set-length ] unit-test-fails
+[ V{ } ] [ [ ] >vector ] unit-test
+[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
100 [ drop 100 random-int ] map >vector
dup >list >vector =
] unit-test
-[ f ] [ { } { 1 2 3 } = ] unit-test
-[ f ] [ { 1 2 } { 1 2 3 } = ] unit-test
-[ f ] [ [ 1 2 ] { 1 2 3 } = ] unit-test
-[ f ] [ { 1 2 } [ 1 2 3 ] = ] unit-test
+[ f ] [ V{ } V{ 1 2 3 } = ] unit-test
+[ f ] [ V{ 1 2 } V{ 1 2 3 } = ] unit-test
+[ f ] [ [ 1 2 ] V{ 1 2 3 } = ] unit-test
+[ f ] [ V{ 1 2 } [ 1 2 3 ] = ] unit-test
[ [ 1 4 9 16 ] ]
[
>vector [ dup * ] map >list
] unit-test
-[ t ] [ { } hashcode { } hashcode = ] unit-test
-[ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test
-[ t ] [ { 1 { 2 } 3 } hashcode { 1 { 2 } 3 } hashcode = ] unit-test
-[ t ] [ { } hashcode { } hashcode = ] unit-test
+[ t ] [ V{ } hashcode V{ } hashcode = ] unit-test
+[ t ] [ V{ 1 2 3 } hashcode V{ 1 2 3 } hashcode = ] unit-test
+[ t ] [ V{ 1 V{ 2 } 3 } hashcode V{ 1 V{ 2 } 3 } hashcode = ] unit-test
+[ t ] [ V{ } hashcode V{ } hashcode = ] unit-test
-[ { 1 2 3 } { 1 2 3 4 5 6 } ]
-[ { 1 2 3 } dup { 4 5 6 } append ] unit-test
+[ V{ 1 2 3 } V{ 1 2 3 4 5 6 } ]
+[ V{ 1 2 3 } dup V{ 4 5 6 } append ] unit-test
[ f ] [ f concat ] unit-test
-[ { 1 2 3 4 } ] [ [ { 1 } [ 2 ] { 3 4 } ] concat ] unit-test
+[ V{ 1 2 3 4 } ] [ [ V{ 1 } [ 2 ] V{ 3 4 } ] concat ] unit-test
-[ { } ] [ 0 { } tail ] unit-test
-[ { } ] [ 2 { 1 2 } tail ] unit-test
-[ { 3 4 } ] [ 2 { 1 2 3 4 } tail ] unit-test
+[ V{ } ] [ 0 V{ } tail ] unit-test
+[ V{ } ] [ 2 V{ 1 2 } tail ] unit-test
+[ V{ 3 4 } ] [ 2 V{ 1 2 3 4 } tail ] unit-test
-[ { 3 } ] [ 1 { 1 2 3 } tail* ] unit-test
+[ V{ 3 } ] [ 1 V{ 1 2 3 } tail* ] unit-test
0 <vector> "funny-stack" set
-[ ] [ { 1 5 } "funny-stack" get push ] unit-test
-[ ] [ { 2 3 } "funny-stack" get push ] unit-test
-[ { 2 3 } ] [ "funny-stack" get pop ] unit-test
-[ { 1 5 } ] [ "funny-stack" get peek ] unit-test
-[ { 1 5 } ] [ "funny-stack" get pop ] unit-test
+[ ] [ V{ 1 5 } "funny-stack" get push ] unit-test
+[ ] [ V{ 2 3 } "funny-stack" get push ] unit-test
+[ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test
+[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test
+[ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test
[ "funny-stack" get pop ] unit-test-fails
[ "funny-stack" get pop ] unit-test-fails
[ ] [ "funky" "funny-stack" get push ] unit-test
[ "funky" ] [ "funny-stack" get pop ] unit-test
[ t ] [
- { 1 2 3 4 } dup underlying length
+ V{ 1 2 3 4 } dup underlying length
>r clone underlying length r>
=
] unit-test
[ f ] [
- { 1 2 3 4 } dup clone
+ V{ 1 2 3 4 } dup clone
[ underlying ] 2apply eq?
] unit-test
] with-scope
] unit-test
-[ -1 ] [ 5 { } index ] unit-test
-[ 4 ] [ 5 { 1 2 3 4 5 } index ] unit-test
+[ -1 ] [ 5 V{ } index ] unit-test
+[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
100 >list dup >vector <reversed> >list >r reverse r> =
[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] string-out ] unit-test
[ "even" ] [
- 2 @{
- @{ [ dup 2 mod 0 = ] [ drop "even" ] }@
- @{ [ dup 2 mod 1 = ] [ drop "odd" ] }@
- }@ cond
+ 2 {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond
] unit-test
[ "odd" ] [
- 3 @{
- @{ [ dup 2 mod 0 = ] [ drop "even" ] }@
- @{ [ dup 2 mod 1 = ] [ drop "odd" ] }@
- }@ cond
+ 3 {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond
] unit-test
[ "neither" ] [
- 3 @{
- @{ [ dup string? ] [ drop "string" ] }@
- @{ [ dup float? ] [ drop "float" ] }@
- @{ [ dup alien? ] [ drop "alien" ] }@
- @{ [ t ] [ drop "neither" ] }@
- }@ cond
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ { [ t ] [ drop "neither" ] }
+ } cond
] unit-test
[ ] [
: dead-code-rec
t [
- #{ 3 2 }#
+ C{ 3 2 }
] [
dead-code-rec
] if ; compiled
-[ #{ 3 2 }# ] [ dead-code-rec ] unit-test
+[ C{ 3 2 } ] [ dead-code-rec ] unit-test
: one-rec [ f one-rec ] [ "hi" ] if ; compiled
[ "even" ] [
[
- 2 @{
- @{ [ dup 2 mod 0 = ] [ drop "even" ] }@
- @{ [ dup 2 mod 1 = ] [ drop "odd" ] }@
- }@ cond
+ 2 {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond
] compile-1
] unit-test
[ "odd" ] [
[
- 3 @{
- { [ dup 2 mod 0 = ] [ drop "even" ] }@
- { [ dup 2 mod 1 = ] [ drop "odd" ] }@
- }@ cond
+ 3 {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond
] compile-1
] unit-test
[ "neither" ] [
[
- 3 @{
- @{ [ dup string? ] [ drop "string" ] }@
- @{ [ dup float? ] [ drop "float" ] }@
- @{ [ dup alien? ] [ drop "alien" ] }@
- @{ [ t ] [ drop "neither" ] }@
- }@ cond
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ { [ t ] [ drop "neither" ] }
+ } cond
] compile-1
] unit-test
: foo 1 2 3 ;
-[ {{ }} ] [ \ foo word-def dataflow kill-set ] unit-test
+[ H{ } ] [ \ foo word-def dataflow kill-set ] unit-test
[ t ] [ [ [ 1 ] [ 2 ] ] [ [ 1 ] [ 2 ] if ] kill-set= ] unit-test
"not a tuple"
] if ; compiled
-[ << pred-test >> "pred-test" ] [ << pred-test >> pred-test-3 ] unit-test
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: pred-test-4
dup pred-test? [
"not a tuple"
] if ; compiled
-[ << pred-test >> "pred-test" ] [ << pred-test >> pred-test-4 ] unit-test
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-4 ] unit-test
! : inline-test
! "nom" = ; compiled
"frame" get 1 2 frame-child label-text
] unit-test
-[ @{ @{ 2 2 2 }@ @{ 3 3 3 }@ @{ 4 4 4 }@ }@ ] [
- @{
- @{ @{ 0 0 0 }@ @{ 1 1 1 }@ @{ 2 2 2 }@ }@
- @{ @{ 0 0 0 }@ @{ 3 3 3 }@ @{ 0 0 0 }@ }@
- @{ @{ 0 0 0 }@ @{ 0 0 0 }@ @{ 4 4 4 }@ }@
- }@ reduce-grid
+[ { { 2 2 2 } { 3 3 3 } { 4 4 4 } } ] [
+ {
+ { { 0 0 0 } { 1 1 1 } { 2 2 2 } }
+ { { 0 0 0 } { 3 3 3 } { 0 0 0 } }
+ { { 0 0 0 } { 0 0 0 } { 4 4 4 } }
+ } reduce-grid
] unit-test
-[ @{ 9 9 9 }@ ] [
- @{
- @{ @{ 0 0 0 }@ @{ 1 1 1 }@ @{ 2 2 2 }@ }@
- @{ @{ 0 0 0 }@ @{ 3 3 3 }@ @{ 0 0 0 }@ }@
- @{ @{ 0 0 0 }@ @{ 0 0 0 }@ @{ 4 4 4 }@ }@
- }@ frame-pref-dim
+[ { 9 9 9 } ] [
+ {
+ { { 0 0 0 } { 1 1 1 } { 2 2 2 } }
+ { { 0 0 0 } { 3 3 3 } { 0 0 0 } }
+ { { 0 0 0 } { 0 0 0 } { 4 4 4 } }
+ } frame-pref-dim
] unit-test
[
- @{
- @{ @{ 1 2 0 }@ @{ 2 2 0 }@ @{ 3 2 0 }@ }@
- @{ @{ 1 4 0 }@ @{ 2 4 0 }@ @{ 3 4 0 }@ }@
- }@
+ {
+ { { 1 2 0 } { 2 2 0 } { 3 2 0 } }
+ { { 1 4 0 } { 2 4 0 } { 3 4 0 } }
+ }
] [
- @{ 1 2 3 }@ @{ 2 4 }@ frame-layout
+ { 1 2 3 } { 2 4 } frame-layout
] unit-test
: sized-gadget ( dim -- gadget )
<gadget> [ set-rect-dim ] keep ;
-[ @{ 90 120 0 }@ ]
+[ { 90 120 0 } ]
[
<frame> "frame" set
- @{ 10 20 0 }@ sized-gadget "frame" get 1 2 frame-add
- @{ 30 40 0 }@ sized-gadget "frame" get 2 0 frame-add
- @{ 50 60 0 }@ sized-gadget "frame" get 0 1 frame-add
+ { 10 20 0 } sized-gadget "frame" get 1 2 frame-add
+ { 30 40 0 } sized-gadget "frame" get 2 0 frame-add
+ { 50 60 0 } sized-gadget "frame" get 0 1 frame-add
"frame" get pref-dim
] unit-test
-[ @{ 180 210 0 }@ ]
+[ { 180 210 0 } ]
[
<frame> "frame" set
- @{ 10 20 0 }@ sized-gadget "frame" get @bottom frame-add
- @{ 30 40 0 }@ sized-gadget "frame" get @top-right frame-add
- @{ 50 60 0 }@ sized-gadget "frame" get @left frame-add
- @{ 100 150 0 }@ sized-gadget "frame" get @center frame-add
+ { 10 20 0 } sized-gadget "frame" get @bottom frame-add
+ { 30 40 0 } sized-gadget "frame" get @top-right frame-add
+ { 50 60 0 } sized-gadget "frame" get @left frame-add
+ { 100 150 0 } sized-gadget "frame" get @center frame-add
"frame" get pref-dim
] unit-test
-[ @{ 30 60 0 }@ ]
+[ { 30 60 0 } ]
[
<frame> "frame" set
- @{ 10 20 0 }@ sized-gadget "frame" get @top frame-add
- @{ 30 40 0 }@ sized-gadget "frame" get @center frame-add
+ { 10 20 0 } sized-gadget "frame" get @top frame-add
+ { 30 40 0 } sized-gadget "frame" get @center frame-add
"frame" get pref-dim
] unit-test
USING: gadgets kernel namespaces test ;
-[ << rect f @{ 10 10 0 }@ @{ 20 20 0 }@ >> ]
+[ T{ rect f { 10 10 0 } { 20 20 0 } } ]
[
- << rect f @{ 10 10 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ -10 -10 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 10 10 0 } { 50 50 0 } }
+ T{ rect f { -10 -10 0 } { 40 40 0 } }
rect-intersect
] unit-test
-[ << rect f @{ 200 200 0 }@ @{ 0 0 0 }@ >> ]
+[ T{ rect f { 200 200 0 } { 0 0 0 } } ]
[
- << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 100 100 0 } { 50 50 0 } }
+ T{ rect f { 200 200 0 } { 40 40 0 } }
rect-intersect
] unit-test
-[ << rect f @{ -10 -10 0 }@ @{ 70 70 0 }@ >> ]
+[ T{ rect f { -10 -10 0 } { 70 70 0 } } ]
[
- << rect f @{ 10 10 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ -10 -10 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 10 10 0 } { 50 50 0 } }
+ T{ rect f { -10 -10 0 } { 40 40 0 } }
rect-union
] unit-test
-[ << rect f @{ 100 100 0 }@ @{ 140 140 0 }@ >> ]
+[ T{ rect f { 100 100 0 } { 140 140 0 } } ]
[
- << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 100 100 0 } { 50 50 0 } }
+ T{ rect f { 200 200 0 } { 40 40 0 } }
rect-union
] unit-test
[ f ] [
- << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 100 100 0 } { 50 50 0 } }
+ T{ rect f { 200 200 0 } { 40 40 0 } }
intersects?
] unit-test
[ t ] [
- << rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ 120 120 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 100 100 0 } { 50 50 0 } }
+ T{ rect f { 120 120 0 } { 40 40 0 } }
intersects?
] unit-test
[ f ] [
- << rect f @{ 1000 100 0 }@ @{ 50 50 0 }@ >>
- << rect f @{ 120 120 0 }@ @{ 40 40 0 }@ >>
+ T{ rect f { 1000 100 0 } { 50 50 0 } }
+ T{ rect f { 120 120 0 } { 40 40 0 } }
intersects?
] unit-test
TUPLE: another-one ;
[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
-[
<< another-one f >> ] [ <another-one> empty-method-test ] unit-test
+[
T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
! Test generic see and parsing
[ "IN: temporary SYMBOL: bah\nUNION: bah fixnum alien ;\n" ]
TUPLE: shit ;
M: shit complex-combination cons ;
-[ [[ << shit f >> 5 ]] ] [ << shit f >> 5 complex-combination ] unit-test
+[ [[ T{ shit f } 5 ]] ] [ T{ shit f } 5 complex-combination ] unit-test
[ t ] [ \ complex-combination generic? >boolean ] unit-test
! G: small-delegation [ over ] [ type ] ;
! M: shit small-delegation cons ;
!
-! [ [[ << shit f >> 5 ]] ] [ << delegating-small-generic << shit f >> >> 5 small-delegation ] unit-test
+! [ [[ T{ shit f } 5 ]] ] [ T{ delegating-small-generic T{ shit f } } 5 small-delegation ] unit-test
GENERIC: big-generic-test
M: fixnum big-generic-test "fixnum" ;
TUPLE: delegating ;
-[ << shit f >> "shit" ] [ << shit f >> big-generic-test ] unit-test
-[ << shit f >> "shit" ] [ << delegating << shit f >> >> big-generic-test ] unit-test
+[ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
+[ T{ shit f } "shit" ] [ T{ delegating T{ shit f } } big-generic-test ] unit-test
[ t ] [ \ = simple-generic? ] unit-test
[ f ] [ \ each simple-generic? ] unit-test
math-internals namespaces parser sequences test vectors ;
[
- << shuffle f { "a" } { } { "a" } { "a" } >>
+ T{ shuffle f { "a" } { } { "a" } { "a" } }
] [
- << shuffle f { "a" } { } { "a" "a" } { } >>
- << shuffle f { "b" } { } { } { "b" } >>
+ T{ shuffle f { "a" } { } { "a" "a" } { } }
+ T{ shuffle f { "b" } { } { } { "b" } }
compose-shuffle
] unit-test
[
- << shuffle f { "b" "a" } { } { "b" "b" } { } >>
+ T{ shuffle f { "b" "a" } { } { "b" "b" } { } }
] [
- << shuffle f { "a" } { } { } { } >>
- << shuffle f { "b" } { } { "b" "b" } { } >>
+ T{ shuffle f { "a" } { } { } { } }
+ T{ shuffle f { "b" } { } { "b" "b" } { } }
compose-shuffle
] unit-test
-[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer ] unit-test
-[ @{ 1 2 }@ ] [ [ dup ] infer ] unit-test
+[ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test
+[ { 1 2 } ] [ [ dup ] infer ] unit-test
-[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer ] unit-test
+[ { 1 2 } ] [ [ [ dup ] call ] infer ] unit-test
[ [ call ] infer ] unit-test-fails
-[ @{ 2 4 }@ ] [ [ 2dup ] infer ] unit-test
+[ { 2 4 } ] [ [ 2dup ] infer ] unit-test
-[ @{ 1 0 }@ ] [ [ [ ] [ ] if ] infer ] unit-test
+[ { 1 0 } ] [ [ [ ] [ ] if ] infer ] unit-test
[ [ if ] infer ] unit-test-fails
[ [ [ ] if ] infer ] unit-test-fails
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
-[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] if ] infer ] unit-test
+[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer ] unit-test
-[ @{ 4 3 }@ ] [
+[ { 4 3 } ] [
[
[
[ swap 3 ] [ nip 5 5 ] if
] infer
] unit-test
-[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer ] unit-test
+[ { 1 1 } ] [ [ dup [ ] when ] infer ] unit-test
+[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
+[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer ] unit-test
-[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
+[ { 1 0 } ] [ [ [ drop ] when* ] infer ] unit-test
+[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
-[ @{ 0 1 }@ ] [
+[ { 0 1 } ] [
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer
] unit-test
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
-[ @{ 1 1 }@ ] [ [ termination-test-2 ] infer ] unit-test
+[ { 1 1 } ] [ [ termination-test-2 ] infer ] unit-test
: infinite-loop infinite-loop ;
: simple-recursion-1
dup [ simple-recursion-1 ] [ ] if ;
-[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer ] unit-test
+[ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test
: simple-recursion-2
dup [ ] [ simple-recursion-2 ] if ;
-[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer ] unit-test
+[ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test
: bad-recursion-2
dup [ uncons bad-recursion-2 ] [ ] if ;
: funny-recursion
dup [ funny-recursion 1 ] [ 2 ] if drop ;
-[ @{ 1 1 }@ ] [ [ funny-recursion ] infer ] unit-test
+[ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test
! Simple combinators
-[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer ] unit-test
+[ { 1 2 } ] [ [ [ car ] keep cdr ] infer ] unit-test
! Mutual recursion
DEFER: foe
2drop f
] if ;
-[ @{ 2 1 }@ ] [ [ fie ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ foe ] infer ] unit-test
+[ { 2 1 } ] [ [ fie ] infer ] unit-test
+[ { 2 1 } ] [ [ foe ] infer ] unit-test
: nested-when ( -- )
t [
] when
] when ;
-[ @{ 0 0 }@ ] [ [ nested-when ] infer ] unit-test
+[ { 0 0 } ] [ [ nested-when ] infer ] unit-test
: nested-when* ( -- )
[
] when*
] when* ;
-[ @{ 1 0 }@ ] [ [ nested-when* ] infer ] unit-test
+[ { 1 0 } ] [ [ nested-when* ] infer ] unit-test
SYMBOL: sym-test
-[ @{ 0 1 }@ ] [ [ sym-test ] infer ] unit-test
+[ { 0 1 } ] [ [ sym-test ] infer ] unit-test
: terminator-branch
dup [
not-a-number
] if ;
-[ @{ 1 1 }@ ] [ [ terminator-branch ] infer ] unit-test
+[ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test
! : recursive-terminator
! dup [
! not-a-number
! ] if ;
!
-! [ @{ 1 0 }@ ] [ [ recursive-terminator ] infer ] unit-test
+! [ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test
GENERIC: potential-hang
M: fixnum potential-hang dup [ potential-hang ] when ;
M: f iterate drop ;
M: real iterate drop ;
-[ @{ 1 0 }@ ] [ [ iterate ] infer ] unit-test
+[ { 1 0 } ] [ [ iterate ] infer ] unit-test
DEFER: agent
: smith 1+ agent ; inline
: agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline
-[ @{ 0 2 }@ ]
+[ { 0 2 } ]
[ [ [ drop ] 0 agent ] infer ] unit-test
! : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
: no-base-case-2 no-base-case-2 ;
[ [ no-base-case-2 ] infer ] unit-test-fails
-[ @{ 2 1 }@ ] [ [ swons ] infer ] unit-test
-[ @{ 1 2 }@ ] [ [ uncons ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ unit ] infer ] unit-test
-[ @{ 1 2 }@ ] [ [ unswons ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ last ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ list? ] infer ] unit-test
-
-[ @{ 1 0 }@ ] [ [ >n ] infer ] unit-test
-[ @{ 0 1 }@ ] [ [ n> ] infer ] unit-test
-
-[ @{ 2 1 }@ ] [ [ bitor ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ bitand ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ bitxor ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ mod ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ /i ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ /f ] infer ] unit-test
-[ @{ 2 2 }@ ] [ [ /mod ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ + ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ - ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ * ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ / ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ < ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ <= ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ > ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ >= ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ number= ] infer ] unit-test
-
-[ @{ 1 1 }@ ] [ [ string>number ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ = ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ get ] infer ] unit-test
-
-[ @{ 2 0 }@ ] [ [ push ] infer ] unit-test
-[ @{ 2 0 }@ ] [ [ set-length ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ append ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ peek ] infer ] unit-test
-
-[ @{ 1 1 }@ ] [ [ length ] infer ] unit-test
-[ @{ 1 1 }@ ] [ [ reverse ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ member? ] infer ] unit-test
-[ @{ 2 1 }@ ] [ [ remove ] infer ] unit-test
+[ { 2 1 } ] [ [ swons ] infer ] unit-test
+[ { 1 2 } ] [ [ uncons ] infer ] unit-test
+[ { 1 1 } ] [ [ unit ] infer ] unit-test
+[ { 1 2 } ] [ [ unswons ] infer ] unit-test
+[ { 1 1 } ] [ [ last ] infer ] unit-test
+[ { 1 1 } ] [ [ list? ] infer ] unit-test
+
+[ { 1 0 } ] [ [ >n ] infer ] unit-test
+[ { 0 1 } ] [ [ n> ] infer ] unit-test
+
+[ { 2 1 } ] [ [ bitor ] infer ] unit-test
+[ { 2 1 } ] [ [ bitand ] infer ] unit-test
+[ { 2 1 } ] [ [ bitxor ] infer ] unit-test
+[ { 2 1 } ] [ [ mod ] infer ] unit-test
+[ { 2 1 } ] [ [ /i ] infer ] unit-test
+[ { 2 1 } ] [ [ /f ] infer ] unit-test
+[ { 2 2 } ] [ [ /mod ] infer ] unit-test
+[ { 2 1 } ] [ [ + ] infer ] unit-test
+[ { 2 1 } ] [ [ - ] infer ] unit-test
+[ { 2 1 } ] [ [ * ] infer ] unit-test
+[ { 2 1 } ] [ [ / ] infer ] unit-test
+[ { 2 1 } ] [ [ < ] infer ] unit-test
+[ { 2 1 } ] [ [ <= ] infer ] unit-test
+[ { 2 1 } ] [ [ > ] infer ] unit-test
+[ { 2 1 } ] [ [ >= ] infer ] unit-test
+[ { 2 1 } ] [ [ number= ] infer ] unit-test
+
+[ { 1 1 } ] [ [ string>number ] infer ] unit-test
+[ { 2 1 } ] [ [ = ] infer ] unit-test
+[ { 1 1 } ] [ [ get ] infer ] unit-test
+
+[ { 2 0 } ] [ [ push ] infer ] unit-test
+[ { 2 0 } ] [ [ set-length ] infer ] unit-test
+[ { 2 1 } ] [ [ append ] infer ] unit-test
+[ { 1 1 } ] [ [ peek ] infer ] unit-test
+
+[ { 1 1 } ] [ [ length ] infer ] unit-test
+[ { 1 1 } ] [ [ reverse ] infer ] unit-test
+[ { 2 1 } ] [ [ member? ] infer ] unit-test
+[ { 2 1 } ] [ [ remove ] infer ] unit-test
: bad-code "1234" car ;
-[ @{ 0 1 }@ ] [ [ bad-code ] infer ] unit-test
+[ { 0 1 } ] [ [ bad-code ] infer ] unit-test
[ 1234 infer ] unit-test-fails
USING: kernel inspector math namespaces prettyprint test
sequences ;
-{ } clone inspector-stack set
+V{ } clone inspector-stack set
[[ "hello" "world" ]] (inspect)
: run ( -- ) [ do ] interpret ;
: init-interpreter ( -- )
- { } clone meta-r set
- { } clone meta-d set
+ V{ } clone meta-r set
+ V{ } clone meta-d set
namestack meta-n set
catchstack meta-c set
meta-cf off
: test-interpreter
init-interpreter meta-cf set run meta-d get ;
-[ { 1 2 3 } ] [
+[ V{ 1 2 3 } ] [
[ 1 2 3 ] test-interpreter
] unit-test
-[ { "Yo" 2 } ] [
+[ V{ "Yo" 2 } ] [
[ 2 >r "Yo" r> ] test-interpreter
] unit-test
-[ { 2 } ] [
+[ V{ 2 } ] [
[ t [ 2 ] [ "hi" ] if ] test-interpreter
] unit-test
-[ { "hi" } ] [
+[ V{ "hi" } ] [
[ f [ 2 ] [ "hi" ] if ] test-interpreter
] unit-test
-[ { 4 } ] [
+[ V{ 4 } ] [
[ 2 2 fixnum+ ] test-interpreter
] unit-test
-[ { "Hey" "there" } ] [
+[ V{ "Hey" "there" } ] [
[ [[ "Hey" "there" ]] uncons ] test-interpreter
] unit-test
-[ { t } ] [
+[ V{ t } ] [
[ "XYZ" "XYZ" = ] test-interpreter
] unit-test
-[ { f } ] [
+[ V{ f } ] [
[ "XYZ" "XuZ" = ] test-interpreter
] unit-test
-[ { #{ 1 1.5 }# { } #{ 1 1.5 }# { } } ] [
- [ #{ 1 1.5 }# { } 2dup ] test-interpreter
+[ V{ C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
+ [ C{ 1 1.5 } { } 2dup ] test-interpreter
] unit-test
-[ { 4 } ] [
+[ V{ 4 } ] [
[ 2 2 + ] test-interpreter
] unit-test
-[ { } ] [
+[ V{ } ] [
[ 3 "x" set ] test-interpreter
] unit-test
-[ { 3 } ] [
+[ V{ 3 } ] [
[ 3 "x" set "x" get ] test-interpreter
] unit-test
-[ { "hi\n" } ] [
+[ V{ "hi\n" } ] [
[ [ "hi" print ] string-out ] test-interpreter
] unit-test
-[ { "4\n" } ] [
+[ V{ "4\n" } ] [
[ [ 2 2 + . ] string-out ] test-interpreter
] unit-test
USE: math
USE: test
-[ 1 #{ 0 1 }# rect> ] unit-test-fails
-[ #{ 0 1 }# 1 rect> ] unit-test-fails
+[ 1 C{ 0 1 } rect> ] unit-test-fails
+[ C{ 0 1 } 1 rect> ] unit-test-fails
-[ f ] [ #{ 5 12.5 }# 5 = ] unit-test
-[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# = ] unit-test
-[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# = ] unit-test
+[ f ] [ C{ 5 12.5 } 5 = ] unit-test
+[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
+[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
-[ #{ 2 5 }# ] [ 2 5 rect> ] unit-test
-[ 2 5 ] [ #{ 2 5 }# >rect ] unit-test
-[ #{ 1/2 1 }# ] [ 1/2 i + ] unit-test
-[ #{ 1/2 1 }# ] [ i 1/2 + ] unit-test
-[ t ] [ #{ 11 64 }# #{ 11 64 }# = ] unit-test
-[ #{ 2 1 }# ] [ 2 i + ] unit-test
-[ #{ 2 1 }# ] [ i 2 + ] unit-test
-[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# + ] unit-test
-[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# + ] unit-test
-[ #{ 1.0 1 }# ] [ 1.0 i + ] unit-test
+[ C{ 2 5 } ] [ 2 5 rect> ] unit-test
+[ 2 5 ] [ C{ 2 5 } >rect ] unit-test
+[ C{ 1/2 1 } ] [ 1/2 i + ] unit-test
+[ C{ 1/2 1 } ] [ i 1/2 + ] unit-test
+[ t ] [ C{ 11 64 } C{ 11 64 } = ] unit-test
+[ C{ 2 1 } ] [ 2 i + ] unit-test
+[ C{ 2 1 } ] [ i 2 + ] unit-test
+[ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 } + ] unit-test
+[ 5 ] [ C{ 2 2 } C{ 3 -2 } + ] unit-test
+[ C{ 1.0 1 } ] [ 1.0 i + ] unit-test
-[ #{ 1/2 -1 }# ] [ 1/2 i - ] unit-test
-[ #{ -1/2 1 }# ] [ i 1/2 - ] unit-test
-[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test
-[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test
-[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# - ] unit-test
-[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# - ] unit-test
-[ #{ 1.0 -1 }# ] [ 1.0 i - ] unit-test
+[ C{ 1/2 -1 } ] [ 1/2 i - ] unit-test
+[ C{ -1/2 1 } ] [ i 1/2 - ] unit-test
+[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test
+[ C{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test
+[ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 } - ] unit-test
+[ 4 ] [ C{ 5 10/3 } C{ 1 10/3 } - ] unit-test
+[ C{ 1.0 -1 } ] [ 1.0 i - ] unit-test
-[ #{ 0 1 }# ] [ i 1 * ] unit-test
-[ #{ 0 1 }# ] [ 1 i * ] unit-test
-[ #{ 0 1.0 }# ] [ 1.0 i * ] unit-test
+[ C{ 0 1 } ] [ i 1 * ] unit-test
+[ C{ 0 1 } ] [ 1 i * ] unit-test
+[ C{ 0 1.0 } ] [ 1.0 i * ] unit-test
[ -1 ] [ i i * ] unit-test
-[ #{ 0 1 }# ] [ 1 i * ] unit-test
-[ #{ 0 1 }# ] [ i 1 * ] unit-test
-[ #{ 0 1/2 }# ] [ 1/2 i * ] unit-test
-[ #{ 0 1/2 }# ] [ i 1/2 * ] unit-test
-[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# * ] unit-test
+[ C{ 0 1 } ] [ 1 i * ] unit-test
+[ C{ 0 1 } ] [ i 1 * ] unit-test
+[ C{ 0 1/2 } ] [ 1/2 i * ] unit-test
+[ C{ 0 1/2 } ] [ i 1/2 * ] unit-test
+[ 2 ] [ C{ 1 1 } C{ 1 -1 } * ] unit-test
[ 1 ] [ i -i * ] unit-test
[ -1 ] [ i -i / ] unit-test
-[ #{ 0 1 }# ] [ 1 -i / ] unit-test
-[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# = ] unit-test
+[ C{ 0 1 } ] [ 1 -i / ] unit-test
+[ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 } = ] unit-test
-[ #{ -3 4 }# ] [ #{ 3 -4 }# neg ] unit-test
+[ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test
-[ 5 ] [ #{ 3 4 }# abs ] unit-test
+[ 5 ] [ C{ 3 4 } abs ] unit-test
[ 5 ] [ -5.0 abs ] unit-test
! Make sure arguments are sane
[ 1 ] [ -1 >polar drop ] unit-test
[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
-[ 0 ] [ #{ 1 1 }# quadrant ] unit-test
-[ 1 ] [ #{ -1 1 }# quadrant ] unit-test
-[ 2 ] [ #{ -1 -1 }# quadrant ] unit-test
-[ 3 ] [ #{ 1 -1 }# quadrant ] unit-test
+[ 0 ] [ C{ 1 1 } quadrant ] unit-test
+[ 1 ] [ C{ -1 1 } quadrant ] unit-test
+[ 2 ] [ C{ -1 -1 } quadrant ] unit-test
+[ 3 ] [ C{ 1 -1 } quadrant ] unit-test
[ 0.25 ] [ 2 -2 fpow ] unit-test
[ 4.0 ] [ 16 sqrt ] unit-test
-[ #{ 0 4.0 }# ] [ -16 sqrt ] unit-test
+[ C{ 0 4.0 } ] [ -16 sqrt ] unit-test
[ 4.0 ] [ 2 2 ^ ] unit-test
[ 0.25 ] [ 2 -2 ^ ] unit-test
[ 2 ] [ "[[ 1 2 ]]" parse car cdr ] unit-test
[ "hello" ] [ "[[ 1 \"hello\" ]]" parse car cdr ] unit-test
-[ #{ 1 2 }# ] [ "[[ 1 #{ 1 2 }# ]]" parse car cdr ] unit-test
+[ C{ 1 2 } ] [ "[[ 1 C{ 1 2 } ]]" parse car cdr ] unit-test
! Test EOL comments in multiline strings.
[ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test
[ "4" ] [ 4 unparse ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
-[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# unparse ] unit-test
+[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
[ "+" ] [ \ + unparse ] unit-test
: foo 1 2 3 ;
[ 1 2 3 1 2 3 ] [ bar ] unit-test
-[ @{ 0 3 }@ ] [ [ foo ] infer ] unit-test
+[ { 0 3 } ] [ [ foo ] infer ] unit-test
[ ] [
"IN: temporary : foo ; : bar foo ; : baz foo ; : foo ;" eval
prepare-tests [ test ] subset terpri passed. failed. ;
: tests
- @{
+ {
"lists/cons" "lists/lists" "lists/assoc"
"lists/namespaces"
"combinators"
"gadgets/frames" "memory"
"redefine" "annotate" "binary" "inspector"
"kernel"
- }@ run-tests ;
+ } run-tests ;
: benchmarks
- @{
+ {
"benchmark/empty-loop" "benchmark/fac"
"benchmark/fib" "benchmark/sort"
"benchmark/continuations" "benchmark/ack"
"benchmark/hashtables" "benchmark/strings"
"benchmark/vectors" "benchmark/prettyprint"
"benchmark/image"
- }@ run-tests ;
+ } run-tests ;
: compiler-tests
- @{
+ {
"io/buffer" "compiler/optimizer"
"compiler/simple"
"compiler/stack" "compiler/ifte"
"compiler/generic" "compiler/bail-out"
"compiler/linearizer" "compiler/intrinsics"
"compiler/identities"
- }@ run-tests ;
+ } run-tests ;
TUPLE: circle radius ;
M: circle area circle-radius sq pi * ;
-[ 200 ] [ << rect f 0 0 10 20 >> area ] unit-test
+[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
[ ] [ "IN: temporary SYMBOL: #x TUPLE: #x ;" eval ] unit-test
TUPLE: delegate-clone ;
-[ << delegate-clone << empty f >> >> ]
-[ << delegate-clone << empty f >> >> clone ] unit-test
+[ T{ delegate-clone T{ empty f } } ]
+[ T{ delegate-clone T{ empty f } } clone ] unit-test
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
TUPLE: size-test a b c d ;
[ t ] [
- << size-test >> array-capacity
+ T{ size-test } array-capacity
size-test "tuple-size" word-prop =
] unit-test
: in-thread ( quot -- )
[
schedule-thread
- [ ] set-catchstack { } set-callstack
+ [ ] set-catchstack V{ } set-callstack
try stop
] callcc0 drop ;
: init-threads ( -- )
global [
<queue> \ run-queue set
- { } clone \ sleep-queue set
- {{ }} clone \ timers set
+ V{ } clone \ sleep-queue set
+ H{ } clone \ timers set
] bind ;
M: kernel-error error. ( error -- )
#! Kernel errors are indexed by integers.
- cdr uncons car swap @{
+ cdr uncons car swap {
[ expired-error. ]
[ io-error. ]
[ undefined-word-error. ]
[ heap-scan-error. ]
[ undefined-symbol-error. ]
[ user-interrupt. ]
- }@ dispatch ;
+ } dispatch ;
M: no-method error. ( error -- )
"No suitable method." print
M: complex summary
"a complex number in the "
- swap quadrant @{ "first" "second" "fourth" "third" }@ nth
+ swap quadrant { "first" "second" "fourth" "third" } nth
" quadrant" append3 ;
GENERIC: sheet ( obj -- sheet )
terpri
"inspector " listener-prompt set
[ inspector-stack get "Inspector history:" ] callstack-hook set
- { } clone inspector-stack set
+ V{ } clone inspector-stack set
(inspect)
listener
] with-scope ;
: instances ( quot -- seq )
#! Return a list of all object that return true when the
#! quotation is applied to them.
- [ [ [ swap call ] 2keep rot ?, ] each-object drop ] { } make ;
+ [ [ [ swap call ] 2keep rot ?, ] each-object drop ] V{ } make ;
inline
G: each-slot ( obj quot -- )
num-types zero-array num-types zero-array
[ >r 2dup r> heap-stat-step ] each-object ;
-: heap-stat. ( @{ instances bytes type }@ -- )
+: heap-stat. ( { instances bytes type } -- )
dup first 0 = [
dup third type>class pprint ": " write
dup second pprint " bytes, " write
: meta-r*
#! Stepper call stack, as well as the currently
#! executing quotation.
- [ meta-r get % meta-executing get , meta-cf get , ] @{ }@ make ;
+ [ meta-r get % meta-executing get , meta-cf get , ] { } make ;
: &r
#! Print stepper call stack, as well as the currently
arrow-left [ prev-page ] <book-button> ,
arrow-right [ next-page ] <book-button> ,
arrow-right| [ last-page ] <book-button> ,
- ] @{ }@ make make-shelf ;
+ ] { } make make-shelf ;
C: book-browser ( book -- gadget )
dup delegate>frame
C: border ( child -- border )
dup delegate>gadget
- @{ 5 5 0 }@ over set-border-size
+ { 5 5 0 } over set-border-size
[ add-gadget ] keep ;
: layout-border-loc ( border -- )
[ swap button-gestures ] keep ;
: <highlight-button> ( gadget quot -- button )
- <button> @{ 0 0 0 }@ over set-border-size ;
+ <button> { 0 0 0 } over set-border-size ;
: <roll-button> ( gadget quot -- button )
<highlight-button> dup roll-button-theme ;
TUPLE: button-paint plain rollover pressed ;
: button-paint ( button paint -- button paint )
- @{
- @{ [ over button-pressed? ] [ button-paint-pressed ] }@
- @{ [ over button-rollover? ] [ button-paint-rollover ] }@
- @{ [ t ] [ button-paint-plain ] }@
- }@ cond ;
+ {
+ { [ over button-pressed? ] [ button-paint-pressed ] }
+ { [ over button-rollover? ] [ button-paint-rollover ] }
+ { [ t ] [ button-paint-plain ] }
+ } cond ;
M: button-paint draw-interior ( button paint -- )
button-paint draw-interior ;
swap [ first complete ] with-editor ;
: do-completion ( editor -- )
- dup [ completions ] with-editor @{
- @{ [ dup empty? ] [ 2drop ] }@
- @{ [ dup length 1 = ] [ do-completion-1 ] }@
- @{ [ t ] [ completion-menu ] }@
- }@ cond ;
+ dup [ completions ] with-editor {
+ { [ dup empty? ] [ 2drop ] }
+ { [ dup length 1 = ] [ do-completion-1 ] }
+ { [ t ] [ completion-menu ] }
+ } cond ;
: editor-actions ( editor -- )
- {{
+ H{
[[ [ gain-focus ] [ focus-editor ] ]]
[[ [ lose-focus ] [ unfocus-editor ] ]]
[[ [ button-down 1 ] [ click-editor ] ]]
- [[ [ "BACKSPACE" ] [ [ << char-elt >> delete-prev-elt ] with-editor ] ]]
- [[ [ "DELETE" ] [ [ << char-elt >> delete-next-elt ] with-editor ] ]]
- [[ [ "CTRL" "BACKSPACE" ] [ [ << word-elt >> delete-prev-elt ] with-editor ] ]]
- [[ [ "CTRL" "DELETE" ] [ [ << word-elt >> delete-next-elt ] with-editor ] ]]
- [[ [ "ALT" "BACKSPACE" ] [ [ << document-elt >> delete-prev-elt ] with-editor ] ]]
- [[ [ "ALT" "DELETE" ] [ [ << document-elt >> delete-next-elt ] with-editor ] ]]
- [[ [ "LEFT" ] [ [ << char-elt >> prev-elt ] with-editor ] ]]
- [[ [ "RIGHT" ] [ [ << char-elt >> next-elt ] with-editor ] ]]
- [[ [ "CTRL" "LEFT" ] [ [ << word-elt >> prev-elt ] with-editor ] ]]
- [[ [ "CTRL" "RIGHT" ] [ [ << word-elt >> next-elt ] with-editor ] ]]
- [[ [ "HOME" ] [ [ << document-elt >> prev-elt ] with-editor ] ]]
- [[ [ "END" ] [ [ << document-elt >> next-elt ] with-editor ] ]]
+ [[ [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] ]]
+ [[ [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] ]]
+ [[ [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] ]]
+ [[ [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] ]]
+ [[ [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] ]]
+ [[ [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] ]]
+ [[ [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] ]]
+ [[ [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] ]]
+ [[ [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] ]]
+ [[ [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] ]]
+ [[ [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] ]]
+ [[ [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] ]]
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
[[ [ "TAB" ] [ do-completion ] ]]
- }} add-actions ;
+ } add-actions ;
C: editor ( text -- )
dup delegate>gadget
0 0 3array ;
: caret-dim ( editor -- w h )
- rect-dim @{ 0 1 1 }@ v* @{ 1 0 0 }@ v+ ;
+ rect-dim { 0 1 1 } v* { 1 0 0 } v+ ;
M: editor user-input* ( ch editor -- ? )
[ insert-char ] with-editor f ;
M: editor pref-dim ( editor -- dim )
- label-size @{ 1 0 0 }@ v+ ;
+ label-size { 1 0 0 } v+ ;
M: editor layout* ( editor -- )
dup editor-caret over caret-dim swap set-gadget-dim
TUPLE: frame grid ;
: <frame-grid>
- @{ @{ f f f }@ @{ f f f }@ @{ f f f }@ }@ [ clone ] map ;
+ { { f f f } { f f f } { f f f } } [ clone ] map ;
: @center 1 1 ;
: @left 0 1 ;
[ max-dim ] map ;
: frame-pref-dim ( grid -- dim )
- reduce-grid @{ 0 0 0 }@ [ v+ ] reduce ;
+ reduce-grid { 0 0 0 } [ v+ ] reduce ;
: pref-dim-grid ( grid -- grid )
- [ [ [ pref-dim ] [ @{ 0 0 0 }@ ] if* ] map ] map ;
+ [ [ [ pref-dim ] [ { 0 0 0 } ] if* ] map ] map ;
M: frame pref-dim ( frame -- dim )
frame-grid pref-dim-grid
SYMBOL: origin
-@{ 0 0 0 }@ origin global set-hash
+{ 0 0 0 } origin global set-hash
TUPLE: rect loc dim ;
M: array rect-loc ;
-M: array rect-dim drop @{ 0 0 0 }@ ;
+M: array rect-dim drop { 0 0 0 } ;
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
: gadget-child gadget-children first ;
C: gadget ( -- gadget )
- @{ 0 0 0 }@ dup <rect> over set-delegate dup show-gadget
- @{ 0 1 0 }@ over set-gadget-orientation ;
+ { 0 0 0 } dup <rect> over set-delegate dup show-gadget
+ { 0 1 0 } over set-gadget-orientation ;
: delegate>gadget ( tuple -- ) <gadget> swap set-delegate ;
] [ 2drop f ] if
] with-scope ;
-: max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ;
+: max-dim ( dims -- dim ) { 0 0 0 } [ vmax ] reduce ;
: set-gadget-delegate ( delegate gadget -- )
dup pick gadget-children [ set-gadget-parent ] each-with
: init-gestures ( gadget -- gestures )
dup gadget-gestures
- [ ] [ {{ }} clone dup rot set-gadget-gestures ] ?if ;
+ [ ] [ H{ } clone dup rot set-gadget-gestures ] ?if ;
: set-action ( gadget quot gesture -- )
rot init-gestures set-hash ;
TUPLE: hand click-loc click-rel clicked buttons gadget focus ;
C: hand ( -- hand )
- dup delegate>gadget { } clone over set-hand-buttons ;
+ dup delegate>gadget V{ } clone over set-hand-buttons ;
: button/ ( n hand -- )
dup hand-gadget over set-hand-clicked
: parents ( gadget -- vector )
#! A list of all parents of the gadget, the first element
#! is the gadget itself.
- { } clone [ (parents) ] keep ;
+ V{ } clone [ (parents) ] keep ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
: screen-loc ( gadget -- point )
#! The position of the gadget on the screen.
- parents @{ 0 0 0 }@ [ rect-loc v+ ] reduce ;
+ parents { 0 0 0 } [ rect-loc v+ ] reduce ;
: gadget-point ( gadget vector -- point )
- #! @{ 0 0 0 }@ - top left corner
- #! @{ 1/2 1/2 0 }@ - middle
- #! @{ 1 1 0 }@ - bottom right corner
+ #! { 0 0 0 } - top left corner
+ #! { 1/2 1/2 0 } - middle
+ #! { 1 1 0 } - bottom right corner
>r dup screen-loc swap rect-dim r> v* v+ ;
: relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ;
: clear-incremental ( incremental -- )
dup (clear-gadget)
- @{ 0 0 0 }@ over set-incremental-cursor
+ { 0 0 0 } over set-incremental-cursor
gadget-parent [ relayout ] when* ;
2dup packed-dim-2 swap orient ;
: packed-loc-1 ( gadget sizes -- seq )
- @{ 0 0 0 }@ [ v+ over pack-gap v+ ] accumulate nip ;
+ { 0 0 0 } [ v+ over pack-gap v+ ] accumulate nip ;
: packed-loc-2 ( gadget sizes -- seq )
[
[ set-gadget-orientation ] keep
0 over set-pack-align
0 over set-pack-fill
- @{ 0 0 0 }@ over set-pack-gap ;
+ { 0 0 0 } over set-pack-gap ;
: delegate>pack ( vector tuple -- ) >r <pack> r> set-delegate ;
-: <pile> ( -- pack )
@{ 0 1 0 }@ <pack> ;
+: <pile> ( -- pack )
{ 0 1 0 } <pack> ;
-: <shelf> ( -- pack )
@{ 1 0 0 }@ <pack> ;
+: <shelf> ( -- pack )
{ 1 0 0 } <pack> ;
M: pack pref-dim ( pack -- dim )
[
[
pref-dims [ max-dim ] keep
- [ @{ 0 0 0 }@ [ v+ ] reduce ] keep length 1 - 0 max
+ [ { 0 0 0 } [ v+ ] reduce ] keep length 1 - 0 max
] keep pack-gap n*v v+
] keep gadget-orientation set-axis ;
C: stack ( -- gadget )
#! A stack lays out all its children on top of each other.
- @{ 0 0 1 }@ over delegate>pack 1 over set-pack-fill ;
+ { 0 0 1 } over delegate>pack 1 over set-pack-fill ;
M: stack children-on ( point stack -- gadget )
nip gadget-children ;
[
"" line-text set
0 <point> caret set
- { } clone history set
+ V{ } clone history set
0 history-index set
possibilities off
] make-hash ;
[ drop ] [ 1+ goto-history ] if ;
: completions ( -- seq )
- << word-elt >> prev-elt@ 2dup = [
+ T{ word-elt } prev-elt@ 2dup = [
2drop f
] [
line-text get subseq possibilities get
] if ;
: complete ( completion -- )
- << word-elt >> prev-elt@ line-replace ;
+ T{ word-elt } prev-elt@ line-replace ;
M: polygon draw-interior ( gadget polygon -- )
[ gl-fill-poly ] draw-polygon drop ;
-: arrow-up @{ @{ @{ 3 0 0 }@ @{ 6 6 0 }@ @{ 0 6 0 }@ }@ }@ ;
-: arrow-right @{ @{ @{ 0 0 0 }@ @{ 6 3 0 }@ @{ 0 6 0 }@ }@ }@ ;
-: arrow-down @{ @{ @{ 0 0 0 }@ @{ 6 0 0 }@ @{ 3 6 0 }@ }@ }@ ;
-: arrow-left @{ @{ @{ 0 3 0 }@ @{ 6 0 0 }@ @{ 6 6 0 }@ }@ }@ ;
+: arrow-up { { { 3 0 0 } { 6 6 0 } { 0 6 0 } } } ;
+: arrow-right { { { 0 0 0 } { 6 3 0 } { 0 6 0 } } } ;
+: arrow-down { { { 0 0 0 } { 6 0 0 } { 3 6 0 } } } ;
+: arrow-left { { { 0 3 0 } { 6 0 0 } { 6 6 0 } } } ;
: arrow-right|
- @{ @{ @{ 6 0 0 }@ @{ 6 6 0 }@ }@ }@ arrow-right append ;
+ { { { 6 0 0 } { 6 6 0 } } } arrow-right append ;
: arrow-|left
- @{ @{ @{ 1 0 0 }@ @{ 1 6 0 }@ }@ }@ arrow-left append ;
+ { { { 1 0 0 } { 1 6 0 } } } arrow-left append ;
: <polygon-gadget> ( color points -- gadget )
- dup @{ 0 0 0 }@ [ max-dim vmax ] reduce
+ dup { 0 0 0 } [ max-dim vmax ] reduce
>r <polygon> <gadget> r> over set-rect-dim
[ set-gadget-interior ] keep ;
dup pane-output clear-incremental pane-current clear-gadget ;
: pane-actions ( line -- )
- {{
+ H{
[[ [ button-down 1 ] [ pane-input [ click-editor ] when* ] ]]
[[ [ "RETURN" ] [ pane-return ] ]]
[[ [ "UP" ] [ pane-input [ [ history-prev ] with-editor ] when* ] ]]
[[ [ "DOWN" ] [ pane-input [ [ history-next ] with-editor ] when* ] ]]
[[ [ "CTRL" "l" ] [ pane get pane-clear ] ]]
- }} add-actions ;
+ } add-actions ;
C: pane ( input? scrolls? -- pane )
#! You can create output-only panes. If the scrolls flag is
: prepare-print ( current -- gadget )
#! Optimization: if line has 1 child, add the child.
- dup gadget-children @{
- @{ [ dup empty? ] [ 2drop "" <label> ] }@
- @{ [ dup length 1 = ] [ nip first ] }@
- @{ [ t ] [ drop ] }@
- }@ cond ;
+ dup gadget-children {
+ { [ dup empty? ] [ 2drop "" <label> ] }
+ { [ dup length 1 = ] [ nip first ] }
+ { [ t ] [ drop ] }
+ } cond ;
: pane-print-1 ( current pane -- )
>r prepare-print r> pane-output add-incremental ;
SYMBOL: commands
-{ } clone commands global set-hash
+V{ } clone commands global set-hash
: define-command ( class name quot -- )
3array commands get push ;
! The follows slot is set by scroll-to.
TUPLE: scroller viewport x y follows ;
-: scroller-origin ( scroller -- @{ x y 0 }@ )
+: scroller-origin ( scroller -- { x y 0 } )
dup scroller-x slider-value
swap scroller-y slider-value
0 3array ;
dup pop-follows dup [
swap scroller-viewport (do-scroll)
] [
- 2drop @{ 0 0 0 }@
+ 2drop { 0 0 0 }
] if ;
: update-scroller ( scroller -- )
: slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
-: slider-vertical? gadget-orientation @{ 0 1 0 }@ = ;
+: slider-vertical? gadget-orientation { 0 1 0 } = ;
: <slide-button> ( orientation polygon amount -- )
>r gray swap <polygon-gadget> r>
swap slider-vertical? arrow-up arrow-left ? -1
<slide-button> ;
-: add-up @{ 1 1 1 }@ over gadget-orientation v- first2 frame-add ;
+: add-up { 1 1 1 } over gadget-orientation v- first2 frame-add ;
: <down-button> ( slider orientation -- button )
swap slider-vertical? arrow-down arrow-right ? 1
<slide-button> ;
-: add-down @{ 1 1 1 }@ over gadget-orientation v+ first2 frame-add ;
+: add-down { 1 1 1 } over gadget-orientation v+ first2 frame-add ;
: add-elevator 2dup set-slider-elevator @center frame-add ;
: add-thumb 2dup slider-elevator add-gadget set-slider-thumb ;
: slider-opposite ( slider -- vector )
- gadget-orientation @{ 1 1 0 }@ swap v- ;
+ gadget-orientation { 1 1 0 } swap v- ;
C: slider ( vector -- slider )
dup delegate>frame
2dup <down-button> pick add-down
<thumb> over add-thumb ;
-: <x-slider> ( -- slider ) @{ 1 0 0 }@ <slider> ;
+: <x-slider> ( -- slider ) { 1 0 0 } <slider> ;
-: <y-slider> ( -- slider ) @{ 0 1 0 }@ <slider> ;
+: <y-slider> ( -- slider ) { 0 1 0 } <slider> ;
TUPLE: divider splitter ;
-: divider-size @{ 8 8 0 }@ ;
+: divider-size { 8 8 0 } ;
M: divider pref-dim drop divider-size ;
: divider-motion ( splitter -- )
dup hand>split
- over rect-dim @{ 1 1 1 }@ vmax v/ over gadget-orientation v.
+ over rect-dim { 1 1 1 } vmax v/ over gadget-orientation v.
0 max 1 min over set-splitter-split relayout-1 ;
: divider-actions ( thumb -- )
1 over set-pack-fill ;
: <x-splitter> ( first second split -- splitter )
- @{ 0 1 0 }@ <splitter> ;
+ { 0 1 0 } <splitter> ;
: <y-splitter> ( first second split -- splitter )
- @{ 1 0 0 }@ <splitter> ;
+ { 1 0 0 } <splitter> ;
: splitter-part ( splitter -- vec )
dup splitter-split swap rect-dim
n*v [ >fixnum ] map divider-size 1/2 v*n v- ;
-: splitter-layout ( splitter -- @{ a b c }@ )
+: splitter-layout ( splitter -- { a b c } )
[
dup splitter-part ,
divider-size ,
dup rect-dim divider-size v- swap splitter-part v- ,
- ] @{ }@ make ;
+ ] { } make ;
M: splitter layout* ( splitter -- )
dup splitter-layout packed-layout ;
IN: gadgets-theme
USING: arrays gadgets kernel sequences styles ;
-: solid-black << solid f @{ 0.0 0.0 0.0 1.0 }@ >> ;
+: solid-black T{ solid f { 0.0 0.0 0.0 1.0 } } ;
-: solid-white << solid f @{ 1.0 1.0 1.0 1.0 }@ >> ;
+: solid-white T{ solid f { 1.0 1.0 1.0 1.0 } } ;
: solid-interior solid-white swap set-gadget-interior ;
: solid-boundary solid-black swap set-gadget-boundary ;
: plain-gradient
- << gradient f @{
- @{ 0.94 0.94 0.94 1.0 }@
- @{ 0.83 0.83 0.83 1.0 }@
- @{ 0.83 0.83 0.83 1.0 }@
- @{ 0.62 0.62 0.62 1.0 }@
- }@ >> ;
+ T{ gradient f {
+ { 0.94 0.94 0.94 1.0 }
+ { 0.83 0.83 0.83 1.0 }
+ { 0.83 0.83 0.83 1.0 }
+ { 0.62 0.62 0.62 1.0 }
+ } } ;
: rollover-gradient
- << gradient f @{
- @{ 1.0 1.0 1.0 1.0 }@
- @{ 0.9 0.9 0.9 1.0 }@
- @{ 0.9 0.9 0.9 1.0 }@
- @{ 0.75 0.75 0.75 1.0 }@
- }@ >> ;
+ T{ gradient f {
+ { 1.0 1.0 1.0 1.0 }
+ { 0.9 0.9 0.9 1.0 }
+ { 0.9 0.9 0.9 1.0 }
+ { 0.75 0.75 0.75 1.0 }
+ } } ;
: pressed-gradient
- << gradient f @{
- @{ 0.75 0.75 0.75 1.0 }@
- @{ 0.9 0.9 0.9 1.0 }@
- @{ 0.9 0.9 0.9 1.0 }@
- @{ 1.0 1.0 1.0 1.0 }@
- }@ >> ;
+ T{ gradient f {
+ { 0.75 0.75 0.75 1.0 }
+ { 0.9 0.9 0.9 1.0 }
+ { 0.9 0.9 0.9 1.0 }
+ { 1.0 1.0 1.0 1.0 }
+ } } ;
: faint-boundary
- << solid f @{ 0.62 0.62 0.62 0.8 }@ >> swap set-gadget-boundary ;
+ T{ solid f { 0.62 0.62 0.62 0.8 } } swap set-gadget-boundary ;
: bevel-button-theme ( gadget -- )
plain-gradient rollover-gradient pressed-gradient
f f pressed-gradient <button-paint> swap set-gadget-interior ;
: caret-theme ( caret -- )
- << solid f @{ 1.0 0.0 0.0 1.0 }@ >> swap set-gadget-interior ;
+ T{ solid f { 1.0 0.0 0.0 1.0 } } swap set-gadget-interior ;
: elevator-theme ( elevator -- )
- << gradient f @{
- @{ 0.37 0.37 0.37 1.0 }@
- @{ 0.43 0.43 0.43 1.0 }@
- @{ 0.5 0.5 0.5 1.0 }@
- }@ >> swap set-gadget-interior ;
+ T{ gradient f {
+ { 0.37 0.37 0.37 1.0 }
+ { 0.43 0.43 0.43 1.0 }
+ { 0.5 0.5 0.5 1.0 }
+ } } swap set-gadget-interior ;
: reverse-video-theme ( gadget -- )
solid-black swap set-gadget-interior ;
: display-title-theme
- << solid f @{ 0.84 0.9 1.0 1.0 }@ >> swap set-gadget-interior ;
+ T{ solid f { 0.84 0.9 1.0 1.0 } } swap set-gadget-interior ;
: menu-theme ( menu -- )
dup solid-boundary
- << solid f @{ 0.9 0.9 0.9 0.9 }@ >> swap set-gadget-interior ;
+ T{ solid f { 0.9 0.9 0.9 0.9 } } swap set-gadget-interior ;
: label-theme ( label -- )
- @{ 0.0 0.0 0.0 1.0 }@ over set-label-color
- @{ "Monospaced" plain 12 }@ swap set-label-font ;
+ { 0.0 0.0 0.0 1.0 } over set-label-color
+ { "Monospaced" plain 12 } swap set-label-font ;
: editor-theme ( editor -- )
- @{ 0.0 0.0 0.0 1.0 }@ over set-label-color
- @{ "Monospaced" bold 12 }@ swap set-label-font ;
+ { 0.0 0.0 0.0 1.0 } over set-label-color
+ { "Monospaced" bold 12 } swap set-label-font ;
first-time get [
<world> world set
world get solid-interior
- @{ 800 600 0 }@ world get set-gadget-dim
+ { 800 600 0 } world get set-gadget-dim
<hand> hand set
first-time off
] when
dupd add-gadget prefer ;
: world-clip ( -- )
- @{ 0 0 0 }@ width get height get 0 3array <rect> clip set ;
+ { 0 0 0 } width get height get 0 3array <rect> clip set ;
: draw-world ( -- )
[ world-clip world get draw-gadget ] with-gl-surface ;
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
- {{ }} clone read-tasks set
+ H{ } clone read-tasks set
FD_SETSIZE <bit-array> read-fdset set
- {{ }} clone write-tasks set
+ H{ } clone write-tasks set
FD_SETSIZE <bit-array> write-fdset set
0 1 t <fd-stream> stdio set
] bind ;
: recrossref ( -- )
#! Update word cross referencing information.
- {{ }} clone crossref global set-hash
+ H{ } clone crossref global set-hash
[ add-crossref ] each-word ;
: lookup ( name vocab -- word ) vocab ?hash ;
"overlapped-ext" c-size malloc <alien> ;
C: io-queue ( -- queue )
- { } clone over set-io-queue-callbacks ;
+ V{ } clone over set-io-queue-callbacks ;
C: io-callback ( -- callback )
io-queue get io-queue-callbacks [ push ] 2keep
: usages ( word -- deps )
#! List all usages of a word. This is a transitive closure,
#! so indirect usages are reported.
- crossref get dup [ closure ] [ 2drop @{ }@ ] if ;
+ crossref get dup [ closure ] [ 2drop { } ] if ;
: usage ( word -- list )
#! List all direct usages of a word.
[ f swap set-word-prop ] each-with ;
: reset-word ( word -- )
- @{
+ {
"parsing" "inline" "foldable" "flushable" "predicating"
"documentation" "stack-effect"
- }@ reset-props ;
+ } reset-props ;
: reset-generic ( word -- )
- dup reset-word @{ "methods" "combination" }@ reset-props ;
+ dup reset-word { "methods" "combination" } reset-props ;
M: word literalize <wrapper> ;
projects / factor.git / commitdiff