\r
- swap @{ and { syntax\r
- get stuff in examples dir running in the ui\r
-- [ ... is annoying\r
- perhaps on the last line of output, if a block doesn't fit, print\r
- it anyway?\r
-- deallocate textures and display lists\r
- pixelColor replacement\r
-- fix presentations\r
-- gadget-children on f error with outliners\r
-\r
+X\r
+ ui:\r
\r
- make-pane: if no input, just return pane-output\r
+ ffi:\r
\r
- C structs, enums, unions: use new-style string mode parsing\r
-- alien/c-types.factor is ugly\r
- smarter out parameter handling\r
- clarify powerpc passing of value struct parameters\r
- ffi unicode strings: null char security hole\r
] "" make ;
: hex-color, ( triplet -- )
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+ 3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
+: assoc-apply ( value-alist quot-alist -- )
+ #! Looks up the key of each pair in the first list in the
+ #! second list to produce a quotation. The quotation is
+ #! applied to the value of the pair. If there is no
+ #! corresponding quotation, the value is popped off the
+ #! stack.
+ swap [
+ unswons rot assoc* dup [ cdr call ] [ 2drop ] if
+ ] each-with ;
+
: css-style ( style -- )
[
[
[ 0 ] [ { 1 } var ] unit-test
[ 0 ] [ { 1 } std ] unit-test
+[ 3 ] [ 5 7 mod-inv ] unit-test
+[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
] ?if ;
: c-size ( name -- size )
- c-type [ "width" get ] bind ;
+ "width" swap c-type hash ;
+
+: c-getter ( name -- quot )
+ "getter" swap c-type hash ;
+
+: c-setter ( name -- quot )
+ "setter" swap c-type hash ;
: define-c-type ( quot name -- )
>r <c-type> [ swap bind ] keep r> c-types get set-hash ;
: <c-object> ( size -- c-ptr ) cell / ceiling <byte-array> ;
-: <c-array> ( n size -- c-ptr ) * <c-object> ;
-
: define-pointer ( type -- )
"void*" c-type swap "*" append c-types get set-hash ;
: define-deref ( name vocab -- )
>r dup "*" swap append r> create
- "getter" rot c-type hash 0 swons define-compound ;
+ swap c-getter 0 swons define-compound ;
+
+: (c-constructor) ( name vocab type quot -- )
+ >r >r constructor-word r> c-size r> cons define-compound ;
: c-constructor ( name vocab -- )
#! Make a word <foo> where foo is the structure name that
#! allocates a Factor heap-local instance of this structure.
#! Used for C functions that expect you to pass in a struct.
- dupd constructor-word
- swap c-size [ <c-object> ] cons
- define-compound ;
+ over [ <c-object> ] (c-constructor) ;
: array-constructor ( name vocab -- )
#! Make a word <foo-array> ( n -- byte-array ).
- >r dup "-array" append r> constructor-word
- swap c-size [ <c-array> ] cons
- define-compound ;
+ over >r >r "-array" append r> r>
+ [ * <c-object> ] (c-constructor) ;
+
+: (define-nth) ( word type quot -- )
+ >r c-size [ rot * ] cons r> append define-compound ;
: define-nth ( name vocab -- )
- #! Make a word foo-nth ( n alien -- dsplaced-alien ).
+ #! Make a word foo-nth ( n alien -- displaced-alien ).
>r dup "-nth" append r> create
- swap dup c-size [ rot * ] cons "getter" rot c-type hash
- append define-compound ;
+ swap dup c-getter (define-nth) ;
: define-set-nth ( name vocab -- )
- #! Make a word foo-nth ( n alien -- dsplaced-alien ).
+ #! Make a word foo-nth ( n alien -- displaced-alien ).
>r "set-" over "-nth" append3 r> create
- swap dup c-size [ rot * ] cons "setter" rot c-type hash
- append define-compound ;
+ swap dup c-setter (define-nth) ;
: define-out ( name vocab -- )
#! Out parameter constructor for integral types.
- dupd constructor-word
- swap c-type [
- [
- "width" get , \ <c-object> , \ tuck , 0 ,
- "setter" get %
- ] [ ] make
- ] bind define-compound ;
+ over [ <c-object> tuck 0 ] over c-setter append
+ (c-constructor) ;
: init-c-type ( name vocab -- )
over define-pointer
: c-aligned c-size cell align ;
: stack-space ( parameters -- n )
- 0 swap [ c-aligned + ] each ;
+ 0 [ c-aligned + ] reduce ;
: unbox-parameter ( n parameter -- node )
c-type [ "unboxer" get "reg-class" get ] bind %unbox ;
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
- [ drop { } { } ] [ first2 ] if ;
+ [ drop @{ }@ @{ }@ ] [ first2 ] if ;
: parse-arglist ( lst -- types stack effect )
unpair [
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 ;
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
#! current 'in' vocabulary.
- create-in >r
- [ "getter" get ] bind cons r> swap define-compound ;
+ create-in >r c-getter cons r> swap define-compound ;
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
- "set-" swap append create-in >r
- [ "setter" get ] bind cons r> swap define-compound ;
+ "set-" swap append create-in >r c-setter cons r>
+ swap define-compound ;
+
+: c-align c-type [ "align" get ] bind ;
: define-field ( offset type name -- offset )
- >r c-type dup >r [ "align" get ] bind align r> r>
+ >r dup >r c-align align r> r>
"struct-name" get swap "-" swap append3
( offset type name -- )
3dup define-getter 3dup define-setter
- drop [ "width" get ] bind + ;
+ drop c-size + ;
: define-member ( max type -- max )
- c-type [ "width" get ] bind max ;
+ c-size max ;
: define-struct-type ( width -- )
#! Define inline and pointer type for the struct. Pointer
"width" set
cell "align" set
[ swap <displaced-alien> ] "getter" set
- ]
- "struct-name" get define-c-type
+ ] "struct-name" get define-c-type
"struct-name" get "in" get init-c-type ;
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
0 exit\r
] set-boot\r
\r
-0 [ compiled? [ 1+ ] when ] each-word\r
-number>string write " words compiled" print\r
+all-words [ compiled? ] subset length\r
+number>string write " compiled words" print\r
\r
-0 [ drop 1+ ] each-word\r
+all-words [ symbol? ] subset length\r
+number>string write " symbol words" print\r
+\r
+all-words length\r
number>string write " words total" print \r
\r
"Total bootstrap GC time: " write gc-time\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 ;
! 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
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
"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
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 }@ )
: set-assoc ( value key alist -- alist )
#! Adds the key/value pair to the alist.
dupd remove-assoc acons ;
-
-: assoc-apply ( value-alist quot-alist -- )
- #! Looks up the key of each pair in the first list in the
- #! second list to produce a quotation. The quotation is
- #! applied to the value of the pair. If there is no
- #! corresponding quotation, the value is popped off the
- #! stack.
- swap [
- unswons rot assoc* dup [ cdr call ] [ 2drop ] if
- ] each-with ;
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> ;
] if ;
: split-blocks ( linear -- blocks )
- [ 0 swap (split-blocks) ] { } make ;
+ [ 0 swap (split-blocks) ] @{ }@ make ;
SYMBOL: d-height
SYMBOL: r-height
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> =
] [
call
] if ;
-
-\ dataflow profile
-\ linearize profile
-\ split-blocks profile
-\ simplify profile
-\ keep-optimizing profile
-\ literals profile
-\ kill-set profile
-\ kill-node profile
-\ infer-classes profile
-\ solve-recursion profile
-\ post-inline profile
-\ compose-shuffle-nodes profile
-\ static-branch profile
-\ optimize-hooks profile
-\ partial-eval? profile
-\ partial-eval profile
-\ flip-branches profile
-\ apply-identities profile
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
! See the remark on fixnum-mod for vreg usage
drop
in-2
- { << vreg f 1 >> << vreg f 0 >> }
- { << vreg f 2 >> << vreg f 0 >> }
+ @{ << vreg f 1 >> << vreg f 0 >> }@
+ @{ << vreg f 2 >> << vreg f 0 >> }@
%fixnum/mod ,
<< vreg f 2 >> 0 %replace-d ,
<< vreg f 0 >> 1 %replace-d ,
#! 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* ;
#! 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 ;
{{ }} clone open-fonts set
] bind ;
-: free-dlists ( seq -- )
- drop ;
-
-: free-textures ( seq -- )
- drop ;
-
-: free-sprites ( glyphs -- )
- dup [ sprite-dlist ] map free-dlists
- [ sprite-texture ] map free-textures ;
+: free-sprite ( sprite -- )
+ dup sprite-dlist 1 glDeleteLists
+ sprite-texture <uint> 1 swap glDeleteTextures ;
! A font object from FreeType.
! the handle is an FT_Face.
: flush-font ( font -- )
#! Only do this after re-creating a GL context!
- dup font-sprites [ ] subset free-sprites
+ dup font-sprites [ [ free-sprite ] when* ] each
{ } clone swap set-font-sprites ;
: close-font ( font -- )
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 ;
: define-slot ( class slot reader writer -- )
>r >r 2dup r> define-reader r> define-writer ;
-: ?create ( { name vocab }/f -- word )
+: ?create ( @{ name vocab }@ -- word )
dup [ first2 create ] when ;
: intern-slots ( spec -- spec )
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
"Strings are part of a class of objects called sequences."\r
"Two other types of sequences you will use a lot are:"\r
""\r
- " Lists: { 1 3 \"hi\" 10 2 }"\r
+ " Lists: [ 1 3 \"hi\" 10 2 ]"\r
" Vectors: { \"the\" { \"quick\" \"brown\" } \"fox\" }"\r
""\r
"As you can see in the second example, lists and vectors"\r
"can contain any type of object, including other lists"\r
"and vectors."\r
- } {\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
- "* Numbers - higher math"\r
- "--"\r
- [ "2 sqrt ." ]\r
- ""\r
- [ "-1 sqrt ." ]\r
- ""\r
- [ "{ { 10 3 } { 7 5 } { -2 0 } }" ]\r
- [ "{ { 11 2 } { 4 8 } } m." ]\r
- ""\r
- "... and there is much more for the math geeks."\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: @
: 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 "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
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 << 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
[ 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
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
: four-sides ( dim -- )
dup top-left dup top-right dup bottom-right bottom-left ;
-: gl-line ( from to { r g b } -- )
+: gl-line ( from to color -- )
gl-color [ gl-vertex ] 2apply ;
: gl-fill-rect ( dim -- )
#! Draw a filled polygon.
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
-: gl-poly ( points { r g b } -- )
+: gl-poly ( points color -- )
#! Draw a polygon.
GL_LINE_LOOP (gl-poly) ;
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 [
! Later, something better needs to be done.
: modifiers
- {
+ @{
[[ "SHIFT" HEX: 0003 ]]
[[ "CTRL" HEX: 00c0 ]]
[[ "ALT" HEX: 0300 ]]
[[ "META" HEX: 0c00 ]]
- } ;
+ }@ ;
: keysyms
{{
0 column set
0 indent set
0 last-newline set
- 0 line-count set
+ 1 line-count set
string-limit off
] bind
[ set-section-start ] keep
0 over set-section-indent ;
-: section-fits? ( section -- ? )
- margin get dup 0 = [
- 2drop t
- ] [
- >r section-end last-newline get - indent get + r> <=
- ] if ;
-
: line-limit? ( -- ? )
line-limit get dup [ line-count get <= ] when ;
drop
] [
last-newline set
- line-count inc
line-limit? [ "..." write end-printing get continue ] when
+ line-count inc
"\n" write do-indent
] if ;
dup section-nl-after?
[ section-end fresh-line ] [ drop ] if ;
+: section-fits? ( section -- ? )
+ margin get dup 0 = [
+ 2drop t
+ ] [
+ line-limit? pick block? and [
+ 2drop t
+ ] [
+ >r section-end last-newline get - indent get + r> <=
+ ] if
+ ] if ;
+
: pprint-section ( section -- )
dup section-fits?
[ pprint-section* ] [ inset-section ] if ;
: vocab-style ( vocab -- style )
{{
- [[ "syntax" [ [[ foreground [ 128 128 128 ] ]] ] ]]
- [[ "kernel" [ [[ foreground [ 0 0 128 ] ]] ] ]]
- [[ "sequences" [ [[ foreground [ 128 0 0 ] ]] ] ]]
- [[ "math" [ [[ foreground [ 0 128 0 ] ]] ] ]]
- [[ "math-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
- [[ "kernel-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
- [[ "io-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
+ [[ "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 )
#! 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: } }@
+ @{ POSTPONE: @{ POSTPONE: }@ }@
+ @{ POSTPONE: {{ POSTPONE: }} }@
+ @{ POSTPONE: [[ POSTPONE: ]] }@
+ @{ POSTPONE: [[ POSTPONE: ]] }@
+}@ [ first2 define-close define-open ] each
[ 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"
IN: temporary
USE: io
-USE: httpd
USE: lists
USE: test
[ "txt" ] [ "foo.txt" file-extension ] unit-test
[ f ] [ "foobar" file-extension ] unit-test
[ "txt" ] [ "foo.bar.txt" file-extension ] unit-test
-[ "text/plain" ] [ "foo.bar.txt" mime-type ] unit-test
-[ "text/html" ] [ "index.html" mime-type ] unit-test
[
<< rect f @{ 10 10 0 }@ @{ 50 50 0 }@ >>
<< rect f @{ -10 -10 0 }@ @{ 40 40 0 }@ >>
- intersect-rect
+ rect-intersect
] unit-test
[ << rect f @{ 200 200 0 }@ @{ 0 0 0 }@ >> ]
[
<< rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
<< rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >>
- intersect-rect
+ rect-intersect
] unit-test
[ << rect f @{ -10 -10 0 }@ @{ 70 70 0 }@ >> ]
[
<< rect f @{ 10 10 0 }@ @{ 50 50 0 }@ >>
<< rect f @{ -10 -10 0 }@ @{ 40 40 0 }@ >>
- union-rect
+ rect-union
] unit-test
[ << rect f @{ 100 100 0 }@ @{ 140 140 0 }@ >> ]
[
<< rect f @{ 100 100 0 }@ @{ 50 50 0 }@ >>
<< rect f @{ 200 200 0 }@ @{ 40 40 0 }@ >>
- union-rect
+ rect-union
] unit-test
[ f ] [
[[ "two" 2 ]]
[[ "four" 4 ]]
] "value-alist" set
-
-[
- [ "one" + ]
- [ "three" - ]
- [ "four" * ]
-] "quot-alist" set
-
-[ 8 ] [ 1 "value-alist" get "quot-alist" get assoc-apply ] unit-test
-[ 1 ] [ 1 "value-alist" get f assoc-apply ] unit-test
-
-[ [ [ "one" + ] [ "four" * ] ] ] [
- "three" "quot-alist" get remove-assoc
-] unit-test
[ t ] [ 123 124 verify-gcd ] unit-test
[ t ] [ 50 120 verify-gcd ] unit-test
-[ 3 ] [ 5 7 mod-inv ] unit-test
-[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
[ -1 ] [ -1 >bignum >fixnum ] unit-test
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 ;
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 )
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
font-size swap assoc [ 12 ] unless* 3array ;
: <styled-label> ( style text -- label )
- <label> foreground pick assoc over set-label-text
+ <label> foreground pick assoc [ over set-label-color ] when*
swap style-font over set-label-font ;
: <presentation> ( style text -- presentation )
! 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 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 ;
}@ >> ;
: faint-boundary
- << solid f @{ 0.62 0.62 0.62 1.0 }@ >> swap set-gadget-boundary ;
+ << solid f @{ 0.62 0.62 0.62 0.8 }@ >> swap set-gadget-boundary ;
: bevel-button-theme ( gadget -- )
plain-gradient rollover-gradient pressed-gradient
: roll-button-theme ( button -- )
f solid-black solid-black <button-paint> over set-gadget-boundary
- f f << solid f @{ 0.92 0.9 0.9 1.0 }@ >> <button-paint> swap set-gadget-interior ;
+ 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 ;
: 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