namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators ;
+accessors combinators effects ;
IN: alien.c-types
DEFER: <int>
>r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- )
- [ to-array-word ] 2keep >c-array-quot define ;
+ [ to-array-word ] 2keep >c-array-quot
+ (( array -- byte-array )) define-declared ;
: c-array>quot ( type vocab -- quot )
[
>r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- )
- [ from-array-word ] 2keep c-array>quot define ;
+ [ from-array-word ] 2keep c-array>quot
+ (( c-ptr n -- array )) define-declared ;
: define-primitive-type ( type name -- )
"alien.c-types"
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
-: pop-parameters pop-literal nip [ expand-constants ] map ;
+: pop-parameters ( -- seq )
+ pop-literal nip [ expand-constants ] map ;
: stdcall-mangle ( symbol node -- symbol )
"@"
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
-: eval-callback
+: eval-callback ( -- callback )
"void*" { "char*" } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
-: yield-callback
+: yield-callback ( -- callback )
"void" { } "cdecl" [ yield ] alien-callback ;
-: sleep-callback
+: sleep-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
enable-compiler
-: compile-uncompiled [ compiled? not ] filter compile ;
+: compile-uncompiled ( words -- )
+ [ compiled? not ] filter compile ;
nl
"Compiling..." write flush
: 1-offset 8 ; inline
: -1-offset 9 ; inline
-: array-start 2 bootstrap-cells object tag-number - ;
-: scan@ array-start bootstrap-cell - ;
-: wrapper@ bootstrap-cell object tag-number - ;
-: word-xt@ 8 bootstrap-cells object tag-number - ;
-: quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 3 bootstrap-cells object tag-number - ;
-
: jit-define ( quot rc rt offset name -- )
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! Bignums
-: bignum-bits bootstrap-cell-bits 2 - ;
+: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
-: bignum-radix bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
! Padded with fixnums for 8-byte alignment
-: t, t t-offset fixup ;
+: t, ( -- ) t t-offset fixup ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f tag-number ;
-: 0, 0 >bignum ' 0-offset fixup ;
-: 1, 1 >bignum ' 1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
+: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
+: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
! Words
"\""
"#!"
"("
+ "(("
":"
";"
"<PRIVATE"
\ flatten-class must-infer\r
\ flatten-builtin-class must-infer\r
\r
-: class= [ class<= ] [ swap class<= ] 2bi and ;\r
+: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;\r
\r
-: class-and* >r class-and r> class= ;\r
+: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
\r
-: class-or* >r class-or r> class= ;\r
+: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
\r
[ t ] [ object object object class-and* ] unit-test\r
[ t ] [ fixnum object fixnum class-and* ] unit-test\r
[ f ] [ null { number fixnum null } min-class ] unit-test\r
\r
! Test for hangs?\r
-: random-class classes random ;\r
+: random-class ( -- class ) classes random ;\r
\r
-: random-op\r
+: random-op ( -- word )\r
{\r
class-and\r
class-or\r
] unit-test\r
] times\r
\r
-: random-boolean\r
+: random-boolean ( -- ? )\r
{ t f } random ;\r
\r
-: boolean>class\r
+: boolean>class ( ? -- class )\r
object null ? ;\r
\r
-: random-boolean-op\r
+: random-boolean-op ( -- word )\r
{\r
and\r
or\r
xor\r
} random ;\r
\r
-: class-xor [ class-or ] 2keep class-and class-not class-and ;\r
+: class-xor ( cls1 cls2 -- cls3 )\r
+ [ class-or ] 2keep class-and class-not class-and ;\r
\r
-: boolean-op>class-op\r
+: boolean-op>class-op ( word -- word' )\r
{\r
{ and class-and }\r
{ or class-or }\r
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
-GENERIC: empty-union-test
+GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
-GENERIC: method-forget-test
+GENERIC: method-forget-test ( obj -- obj )
TUPLE: method-forget-class ;
M: method-forget-class method-forget-test ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
-: predicate-effect 1 { "?" } <effect> ;
+: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
-: <rect> rect boa ;
+: <rect> ( x y w h -- rect ) rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
PREDICATE: silly-pred < tuple
class \ rect = ;
-GENERIC: area
+GENERIC: area ( obj -- n )
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
[ 1 ] [ <t4> 1 m2 ] unit-test
! another combination issue
-GENERIC: silly
+GENERIC: silly ( obj -- obj obj )
UNION: my-union slice repetition column array vector reversed ;
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem new ;
-: cons-test-2 \ erg's-reshape-problem boa ;
+: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
+: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
-: test-laptop-slot-values
+: test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
-: test-server-slot-values
+: test-server-slot-values ( -- )
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
"a" "b" <test2> "test" set
-: test-a/b
+: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
-: test-move-up
+: test-move-up ( -- )
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;
main-vocab-hook get [ call ] [ "listener" ] if*
] if ;
-: default-cli-args
+: default-cli-args ( -- )
global [
"quiet" off
"script" off
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
-: card-mark HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
-: float-offset 8 float tag-number - ;
-: string-offset 4 bootstrap-cells object tag-number - ;
-: profile-count-offset 7 bootstrap-cells object tag-number - ;
-: byte-array-offset 2 bootstrap-cells object tag-number - ;
-: alien-offset 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset bootstrap-cell object tag-number - ;
-: tuple-class-offset bootstrap-cell tuple tag-number - ;
-: class-hash-offset bootstrap-cell object tag-number - ;
-: word-xt-offset 8 bootstrap-cells object tag-number - ;
-: word-code-offset 9 bootstrap-cells object tag-number - ;
-: compiled-header-size 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ;
+: float-offset ( -- n ) 8 float tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: compiled-header-size ( -- n ) 4 bootstrap-cells ;
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
-: :errors +error+ compiler-errors. ;
+: :errors ( -- ) +error+ compiler-errors. ;
-: :warnings +warning+ compiler-errors. ;
+: :warnings ( -- ) +warning+ compiler-errors. ;
-: :linkage +linkage+ compiler-errors. ;
+: :linkage ( -- ) +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
! Some randomized tests
: compiled-fixnum* fixnum* ;
-: test-fixnum*
+: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
: compiled-fixnum>bignum fixnum>bignum ;
-: test-fixnum>bignum
+: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
: compiled-bignum>fixnum bignum>fixnum ;
-: test-bignum>fixnum
+: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def word-def [ { fixnum } declare ] prepend ;
+: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
! Regression
-: empty ;
+: empty ( -- ) ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
-: dummy-if-1 t [ ] [ ] if ;
+: dummy-if-1 ( -- ) t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
-: dummy-if-2 f [ ] [ ] if ;
+: dummy-if-2 ( -- ) f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
-: dummy-if-3 t [ 1 ] [ 2 ] if ;
+: dummy-if-3 ( -- ) t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
-: dummy-if-4 f [ 1 ] [ 2 ] if ;
+: dummy-if-4 ( -- ) f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
-: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
+: dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
-: dummy-if-6
+: dummy-if-6 ( n -- n )
dup 1 fixnum<= [
drop 1
] [
[ 17 ] [ 10 dummy-if-6 ] unit-test
-: dead-code-rec
+: dead-code-rec ( -- obj )
t [
3.2
] [
[ 3.2 ] [ dead-code-rec ] unit-test
-: one-rec [ f one-rec ] [ "hi" ] if ;
+: one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
-: after-if-test
+: after-if-test ( -- n )
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
[ ] [ 10 countdown-b ] unit-test
-: dummy-when-1 t [ ] when ;
+: dummy-when-1 ( -- ) t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
-: dummy-when-2 f [ ] when ;
+: dummy-when-2 ( -- ) f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
-: dummy-when-3 dup [ dup fixnum* ] when ;
+: dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
-: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
+: dummy-when-4 ( a -- b c ) dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
-: dummy-when-5 f [ dup fixnum* ] when ;
+: dummy-when-5 ( -- ) f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
-: dummy-unless-1 t [ ] unless ;
+: dummy-unless-1 ( -- ) t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
-: dummy-unless-2 f [ ] unless ;
+: dummy-unless-2 ( -- ) f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
-: dummy-unless-3 dup [ drop 3 ] unless ;
+: dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
] compile-call
] unit-test
-GENERIC: single-combination-test
+GENERIC: single-combination-test ( obj1 obj2 -- obj )
M: object single-combination-test drop ;
M: f single-combination-test nip ;
DEFER: single-combination-test-2
-: single-combination-test-4
+: single-combination-test-4 ( obj -- obj )
dup [ single-combination-test-2 ] when ;
-: single-combination-test-3
+: single-combination-test-3 ( obj -- obj )
drop 3 ;
-GENERIC: single-combination-test-2
+GENERIC: single-combination-test-2 ( obj -- obj )
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;
error-continuation get continuation-call callstack>array
2 group flip first ;
-: foo 3 throw 7 ;
-: bar foo 4 ;
-: baz bar 5 ;
+: foo ( -- * ) 3 throw 7 ;
+: bar ( -- * ) foo 4 ;
+: baz ( -- * ) bar 5 ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
{ baz bar foo throw } tail?
] unit-test
-: bleh [ 3 + ] map [ 0 > ] filter ;
+: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-contains? symbolic-stack-trace memq? ;
+: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
-: quux { 1 2 3 } [ "hi" throw ] sort ;
+: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
-: foo ;
+: foo ( -- ) ;
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch
+: try-breaking-dispatch ( n a b -- a b str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
-: try-breaking-dispatch-2
+: try-breaking-dispatch-2 ( -- ? )
1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
[ t ] [
] unit-test
! Regression
-: foox
+: foox ( obj -- obj )
dup not
[ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
] unit-test
! Regression
-: a-dummy drop "hi" print ;
+: a-dummy ( -- ) drop "hi" print ;
[ ] [
1 [
] compile-call
] unit-test
-: float-spill-bug
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
#! with a declaration.
f { object } declare ;
-: init-catchstack V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 setenv ;
PRIVATE>
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
-: %prologue-later \ %prologue-later , ;
+: %prologue-later ( -- ) \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
-: %epilogue-later \ %epilogue-later , ;
+: %epilogue-later ( -- ) \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt cpu ( -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
-HOOK: %gc cpu
+HOOK: %gc cpu ( -- )
: operand ( var -- op ) get v>operand ; inline
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
: jit-call-quot ( -- )\r
- temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt\r
+ temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt\r
temp-reg MTCTR ! jump to quotation-xt\r
BCTR ;\r
\r
temp-reg ds-reg 0 LWZ ! load index\r
temp-reg dup 1 SRAWI ! turn it into an array offset\r
quot-reg dup temp-reg ADD ! compute quotation location\r
- quot-reg dup array-start LWZ ! load quotation\r
+ quot-reg dup array-start-offset LWZ ! load quotation\r
ds-reg dup 4 SUBI ! pop index\r
jit-call-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return return-reg stack-reg rot [+] ;
+: load/store-int-return ( n reg-class -- src dst )
+ return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-: FSTP 4 = [ FSTPS ] [ FSTPL ] if ;
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
-: FLD 4 = [ FLDS ] [ FLDL ] if ;
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return reg-size >r stack@ r> ;
+: load/store-float-return ( n reg-class -- op size )
+ [ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
-: (%box-long-long)
+: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
M: x86.32 %box-long-long ( n func -- )
8 [
- >r (%box-long-long) r> f %alien-invoke
+ [ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
M: x86.32 %box-large-struct ( n size -- )
4 "double" c-type set-c-type-align
] unless
-: sse2? "Intrinsic" throw ;
+: sse2? ( -- ? ) "Intrinsic" throw ;
\ sse2? [
{ EAX EBX ECX EDX } [ PUSH ] each
generator.registers system layouts alien ;
IN: cpu.x86.allot
-: allot-reg
+: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
combinators compiler.constants math.order ;
IN: cpu.x86.architecture
-HOOK: ds-reg cpu
-HOOK: rs-reg cpu
-HOOK: stack-reg cpu
-HOOK: stack-save-reg cpu
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
-: stack@ stack-reg swap [+] ;
+: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
-HOOK: temp-reg-1 cpu
-HOOK: temp-reg-2 cpu
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ cpu
+HOOK: fixnum>slot@ cpu ( op -- )
-HOOK: prepare-division cpu
+HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size 4 cells ;
+: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
M: x86 %replace swap %peek ;
-: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ stack-reg \ stack-frame get rot - [+] ;
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
-: REGISTERS:
+: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
M: indirect extended? base>> extended? ;
-: canonicalize-EBP
+: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
- ] when drop ;
+ ] when ;
-: canonicalize-ESP
+: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
- dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
+ dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-: canonicalize ( indirect -- )
+: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
+ canonicalize-EBP canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect boa dup canonicalize ;
+ indirect boa canonicalize ;
-: reg-code "register" word-prop 7 bitand ;
+: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
-: indirect-base* base>> EBP or reg-code ;
+: indirect-base* ( op -- n ) base>> EBP or reg-code ;
-: indirect-index* index>> ESP or reg-code ;
+: indirect-index* ( op -- n ) index>> ESP or reg-code ;
-: indirect-scale* scale>> 0 or ;
+: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
-: 1, 1 n, ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
+: 1, ( n -- ) 1 n, ; inline
+: 4, ( n -- ) 4 n, ; inline
+: 2, ( n -- ) 2 n, ; inline
+: cell, ( n -- ) bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
[ nip operand-64? ]
} cond and ;
-: rex.r
+: rex.r ( m op -- n )
extended? [ BIN: 00000100 bitor ] when ;
-: rex.b
+: rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
index>> extended? [ BIN: 00000010 bitor ] when
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
-: opcode, dup array? [ % ] [ , ] if ;
+: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
-: immediate-operand-size-bit
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1 ( imm dst reg,rex.w,opcode -- )
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
-: immediate-fits-in-size-bit
+: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
! Control flow
GENERIC: JMP ( op -- )
-: (JMP) HEX: e9 , 0 4, rc-relative ;
+: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
-: (CALL) HEX: e8 , 0 4, rc-relative ;
+: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) extended-opcode, 0 4, rc-relative ;
+: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
-: JO HEX: 80 JUMPcc ;
-: JNO HEX: 81 JUMPcc ;
-: JB HEX: 82 JUMPcc ;
-: JAE HEX: 83 JUMPcc ;
-: JE HEX: 84 JUMPcc ; ! aka JZ
-: JNE HEX: 85 JUMPcc ;
-: JBE HEX: 86 JUMPcc ;
-: JA HEX: 87 JUMPcc ;
-: JS HEX: 88 JUMPcc ;
-: JNS HEX: 89 JUMPcc ;
-: JP HEX: 8a JUMPcc ;
-: JNP HEX: 8b JUMPcc ;
-: JL HEX: 8c JUMPcc ;
-: JGE HEX: 8d JUMPcc ;
-: JLE HEX: 8e JUMPcc ;
-: JG HEX: 8f JUMPcc ;
+: JO ( dst -- ) HEX: 80 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
+: JB ( dst -- ) HEX: 82 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
+: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
+: JA ( dst -- ) HEX: 87 JUMPcc ;
+: JS ( dst -- ) HEX: 88 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
+: JP ( dst -- ) HEX: 8a JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
+: JL ( dst -- ) HEX: 8c JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
+: JLE ( dst -- ) HEX: 8e JUMPcc ;
+: JG ( dst -- ) HEX: 8f JUMPcc ;
: LEAVE ( -- ) HEX: c9 , ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-: CDQ HEX: 99 , ;
-: CQO HEX: 48 , CDQ ;
+: CDQ ( -- ) HEX: 99 , ;
+: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
-: CMOVO HEX: 40 MOVcc ;
-: CMOVNO HEX: 41 MOVcc ;
-: CMOVB HEX: 42 MOVcc ;
-: CMOVAE HEX: 43 MOVcc ;
-: CMOVE HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE HEX: 45 MOVcc ;
-: CMOVBE HEX: 46 MOVcc ;
-: CMOVA HEX: 47 MOVcc ;
-: CMOVS HEX: 48 MOVcc ;
-: CMOVNS HEX: 49 MOVcc ;
-: CMOVP HEX: 4a MOVcc ;
-: CMOVNP HEX: 4b MOVcc ;
-: CMOVL HEX: 4c MOVcc ;
-: CMOVGE HEX: 4d MOVcc ;
-: CMOVLE HEX: 4e MOVcc ;
-: CMOVG HEX: 4f MOVcc ;
+: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
+: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
+: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
+: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
+: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
+: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
+: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
+: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
! CPU Identification
-: CPUID HEX: a2 extended-opcode, ;
+: CPUID ( -- ) HEX: a2 extended-opcode, ;
! x87 Floating Point Unit
arg0 \ f tag-number CMP ! compare it with f
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
- arg0 quot-xt@ [+] JMP ! jump to quotation-xt
+ arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
- arg0 arg0 array-start [+] MOV ! load quotation
- arg0 quot-xt@ [+] JMP ! execute branch
+ arg0 arg0 array-start-offset [+] MOV ! load quotation
+ arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
} define-intrinsic
! Slots
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" get operand-tag - [+] ;
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
-: %slot-any
+: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
{ +clobber+ { "offset" } }
} ;
-: define-getter
+: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
-: define-unsigned-getter
+: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
-: define-signed-getter
+: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
{ +clobber+ { "value" "offset" } }
} ;
-: define-setter
+: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template
: :vars ( -- )
error-continuation get continuation-name namestack. ;
-: :res ( n -- )
+: :res ( n -- * )
1- restarts get-global nth f restarts set-global restart ;
-: :1 1 :res ;
-: :2 2 :res ;
-: :3 3 :res ;
+: :1 ( -- * ) 1 :res ;
+: :2 ( -- * ) 2 :res ;
+: :3 ( -- * ) 3 :res ;
: restart. ( restart n -- )
[
: stack-overflow. ( obj name -- )
write " stack overflow" print drop ;
-: datastack-underflow. "Data" stack-underflow. ;
-: datastack-overflow. "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
+: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
+: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
+: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
+: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
-: memory-error.
+: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
-: primitive-error.
+: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
[ second 0 15 between? ]
} cond ;
-: kernel-errors
+: kernel-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
-combinators ;
+combinators accessors ;
IN: effects
TUPLE: effect in out terminated? ;
effect boa ;
: effect-height ( effect -- n )
- dup effect-out length swap effect-in length - ;
+ [ out>> length ] [ in>> length ] bi - ;
: effect<= ( eff1 eff2 -- ? )
{
- { [ dup not ] [ t ] }
- { [ over effect-terminated? ] [ t ] }
- { [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ over terminated?>> ] [ t ] }
+ { [ dup terminated?>> ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
: effect>string ( effect -- string )
[
"( " %
- dup effect-in stack-picture %
- "-- " %
- dup effect-out stack-picture %
- effect-terminated? [ "* " % ] when
+ [ in>> stack-picture % "-- " % ]
+ [ out>> stack-picture % ]
+ [ terminated?>> [ "* " % ] when ]
+ tri
")" %
] "" make ;
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
- [ effect-in clone ] keep effect-out clone <effect> ;
+ [ in>> clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- effect-in length cut* ;
+ in>> length cut* ;
: load-shuffle ( stack shuffle -- )
- effect-in [ set ] 2each ;
+ in>> [ set ] 2each ;
: shuffled-values ( shuffle -- values )
- effect-out [ get ] map ;
+ out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
: word-dataflow ( word -- effect dataflow )
[
- dup "no-effect" word-prop [ no-effect ] when
- dup "no-compile" word-prop [ no-effect ] when
+ dup "cannot-infer" word-prop [ cannot-infer-effect ] when
+ dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> f ds-loc boa ;
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> f rs-loc boa ;
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
<PRIVATE
! Moving values between locations and registers
-: %move-bug "Bug in generator.registers" throw ;
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
-: (loc)
+: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
-GENERIC: generic-forget-test-2
+GENERIC: generic-forget-test-2 ( a b -- c )
M: sequence generic-forget-test-2 = ;
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
-GENERIC: generic-forget-test-3
+GENERIC: generic-forget-test-3 ( a -- b )
M: f generic-forget-test-3 ;
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
-: num-hi-tags num-types get num-tags get - ;
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
-: word-hashcode% [ 1 slot ] % ;
+: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
[
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
-: array-nth% 2 + , [ slot { word } declare ] % ;
+: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
prettyprint byte-vectors bit-vectors float-vectors definitions
generic sets graphs assocs ;
-GENERIC: lo-tag-test
+GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ;
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-GENERIC: hi-tag-test
+GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ;
C: <circle> circle
-GENERIC: area
+GENERIC: area ( shape -- n )
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-GENERIC: perimiter
+GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter + 2 * ;
+: rectangle-perimiter ( n -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
-: hypotenuse [ sq ] bi@ + sqrt ;
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-GENERIC: big-mix-test
+GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ;
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
-GENERIC: small-lo-tag
+GENERIC: small-lo-tag ( obj -- obj )
M: fixnum small-lo-tag drop "fixnum" ;
M: c funky* "c" , call-next-method ;
-: funky [ funky* ] { } make ;
+: funky ( obj -- seq ) [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
TUPLE: xref-tuple-1 ;
TUPLE: xref-tuple-2 < xref-tuple-1 ;
-: (xref-test) drop ;
+: (xref-test) ( obj -- ) drop ;
GENERIC: xref-test ( obj -- )
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
-HELP: no-effect
+HELP: cannot-infer-effect
{ $values { "word" word } }
-{ $description "Throws a " { $link no-effect } " error." }
+{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: inline-word
{ $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
-HELP: no-recursive-declaration
-{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
+HELP: missing-effect
+{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Words not declared " { $link POSTPONE: inline } " must declare a stack effect in order to compile." } ;
HELP: recursive-quotation-error
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
SYMBOL: visited
-: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
#call consume/produce
] if ;
-TUPLE: no-effect word ;
+TUPLE: cannot-infer-effect word ;
-: no-effect ( word -- * ) \ no-effect inference-warning ;
+: cannot-infer-effect ( word -- * )
+ \ cannot-infer-effect inference-warning ;
-TUPLE: effect-error word effect ;
+TUPLE: effect-error word inferred declared ;
-: effect-error ( word effect -- * )
+: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
+TUPLE: missing-effect word ;
+
+: effect-required? ( word -- ? )
+ {
+ { [ dup inline? ] [ drop f ] }
+ { [ dup deferred? ] [ drop f ] }
+ { [ dup crossref? not ] [ drop f ] }
+ [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ } cond ;
+
+: ?missing-effect ( word -- )
+ dup effect-required?
+ [ missing-effect inference-error ] [ drop ] if ;
+
: check-effect ( word effect -- )
- dup pick stack-effect effect<=
- [ 2drop ] [ effect-error ] if ;
+ over stack-effect {
+ { [ dup not ] [ 2drop ?missing-effect ] }
+ { [ 2dup effect<= ] [ 3drop ] }
+ [ effect-error ]
+ } cond ;
: finish-word ( word -- )
current-effect
finish-word
current-effect
] with-scope
- ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
+ ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
: apply-word ( word -- )
{
{ [ dup "infer" word-prop ] [ custom-infer ] }
- { [ dup "no-effect" word-prop ] [ no-effect ] }
+ { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
[ dup infer-word make-call-node ]
} cond ;
-TUPLE: no-recursive-declaration word ;
-
-: declared-infer ( word -- )
+: declared-infer ( word -- )
dup stack-effect [
make-call-node
] [
- \ no-recursive-declaration inference-error
+ \ missing-effect inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
-: inlined-block? "inlined-block" word-prop ;
+: inlined-block? ( word -- ? )
+ "inlined-block" word-prop ;
-: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
+: <inlined-block> ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- #label data )
[
namespace swap update ;
: current-stack-height ( -- n )
- meta-d get length d-in get - ;
+ d-in get meta-d get length - ;
: word-stack-height ( word -- n )
- stack-effect [ in>> length ] [ out>> length ] bi - ;
+ stack-effect effect-height ;
: bad-recursive-declaration ( word inferred -- )
- dup 0 < [ 0 ] [ 0 swap ] if <effect> effect-error ;
+ dup 0 < [ 0 swap ] [ 0 ] if <effect>
+ over stack-effect
+ effect-error ;
: check-stack-height ( word height -- )
over word-stack-height over =
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
! We don't want to use = to compare literals
-: foo reverse ;
+: foo ( seq -- seq' ) reverse ;
\ foo [
[
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
-: `input node get in-d>> nth ;
-: `output node get out-d>> nth ;
-: class, <class-constraint> , ;
-: literal, <literal-constraint> , ;
-: interval, <interval-constraint> , ;
+: `input ( n -- value ) node get in-d>> nth ;
+: `output ( n -- value ) node get out-d>> nth ;
+: class, ( class value -- ) <class-constraint> , ;
+: literal, ( literal value -- ) <literal-constraint> , ;
+: interval, ( interval value -- ) <interval-constraint> , ;
M: f apply-constraint drop ;
IN: inference.dataflow
! Computed value
-: <computed> \ <computed> counter ;
+: <computed> ( -- value ) \ <computed> counter ;
! Literal value
TUPLE: value < identity-tuple literal uid recursion ;
: r-tail ( n -- seq )
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
-: node-child node-children first ;
+: node-child ( node -- child ) node-children first ;
TUPLE: #label < node word loop? returns calls ;
SYMBOL: node-stack
-: >node node-stack get push ;
-: node> node-stack get pop ;
-: node@ node-stack get peek ;
+: >node ( node -- ) node-stack get push ;
+: node> ( -- node ) node-stack get pop ;
+: node@ ( -- node ) node-stack get peek ;
: iterate-next ( -- node ) node@ successor>> ;
drop
"Quotation pops retain stack elements which it did not push" ;
-M: no-effect error.
+M: cannot-infer-effect error.
"Unable to infer stack effect of " write word>> . ;
-M: no-recursive-declaration error.
- "The recursive word " write
+M: missing-effect error.
+ "The word " write
word>> pprint
" must declare a stack effect" print ;
M: effect-error error.
"Stack effects of the word " write
- dup word>> pprint
- " do not match." print
- "Declared: " write
- dup word>> stack-effect effect>string .
- "Inferred: " write effect>> effect>string . ;
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> effect>string . ]
+ [ "Declared: " write declared>> effect>string . ] tri ;
M: recursive-quotation-error error.
"The quotation " write
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
-{ $subsection no-effect }
+{ $subsection cannot-infer-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
-{ $subsection no-recursive-declaration } ;
+{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
] must-fail
! Test inference of termination of control flow
-: termination-test-1
- "foo" throw ;
+: termination-test-1 ( -- * ) "foo" throw ;
-: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
+: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] must-infer-as
-: infinite-loop infinite-loop ;
-
-[ [ infinite-loop ] infer ] must-fail
-
-: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] must-fail
-
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
{ 0 1 } [ sym-test ] must-infer-as
-: terminator-branch
+: terminator-branch ( a -- b )
dup [
length
] [
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
-: bad-input#
+{ 2 2 } [
dup string? [ 2array throw ] unless
- over string? [ 2array throw ] unless ;
-
-{ 2 2 } [ bad-input# ] must-infer-as
+ over string? [ 2array throw ] unless
+] must-infer-as
! Regression
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
-MATH: xyz
+MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx fooxxx ;
+: barxxx ( a b -- c ) fooxxx ;
[ [ barxxx ] infer ] must-fail
DEFER: deferred-word
-: calls-deferred-word [ deferred-word ] [ 3 ] if ;
-
-{ 1 1 } [ calls-deferred-word ] must-infer-as
+{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
USE: inference.dataflow
[ [ erg's-inference-bug ] infer ] must-fail
-: inference-invalidation-a ;
-: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline
-: inference-invalidation-c [ + ] inference-invalidation-b ;
-
-[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-
-{ 2 1 } [ inference-invalidation-c ] must-infer-as
-
-[ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
-
-[ 3 ] [ inference-invalidation-c ] unit-test
-
-{ 0 1 } [ inference-invalidation-c ] must-infer-as
-
-GENERIC: inference-invalidation-d ( obj -- )
-
-M: object inference-invalidation-d inference-invalidation-c 2drop ;
-
-\ inference-invalidation-d must-infer
-
-[ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
-
-[ [ inference-invalidation-d ] infer ] must-fail
+! : inference-invalidation-a ( -- );
+! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
+!
+! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+!
+! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+!
+! [ 3 ] [ inference-invalidation-c ] unit-test
+!
+! { 0 1 } [ inference-invalidation-c ] must-infer-as
+!
+! GENERIC: inference-invalidation-d ( obj -- )
+!
+! M: object inference-invalidation-d inference-invalidation-c 2drop ;
+!
+! \ inference-invalidation-d must-infer
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+!
+! [ [ inference-invalidation-d ] infer ] must-fail
: forget-errors ( -- )
all-words [
- dup subwords [ f "no-effect" set-word-prop ] each
- f "no-effect" set-word-prop
+ dup subwords [ f "cannot-infer" set-word-prop ] each
+ f "cannot-infer" set-word-prop
] each ;
\ (set-os-envs) { array } { } <effect> set-primitive-effect
-\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
! Compile-time data stack
SYMBOL: meta-d
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
+: push-d ( obj -- ) meta-d get push ;
+: pop-d ( -- obj ) meta-d get pop ;
+: peek-d ( -- obj ) meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
+: push-r ( obj -- ) meta-r get push ;
+: pop-r ( -- obj ) meta-r get pop ;
+: peek-r ( -- obj ) meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph
quotations inference accessors combinators words arrays
classes ;
-: compose-n-quot <repetition> >quotation ;
-: compose-n compose-n-quot call ;
+: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
+: compose-n ( quot -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
-: compose-n-test 2 \ + compose-n ;
+: compose-n-test ( -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ new must-infer
-
-TUPLE: a-tuple x y z ;
-
-: set-slots-test ( x y z -- )
- { set-a-tuple-x set-a-tuple-y } set-slots ;
-
-\ set-slots-test must-infer
-
-: set-slots-test-2
- { set-a-tuple-x set-a-tuple-x } set-slots ;
-
-[ [ set-slots-test-2 ] infer ] must-fail
-
TUPLE: color r g b ;
C: <color> color
-: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+: cleave-test ( color -- r g b )
+ { [ r>> ] [ g>> ] [ b>> ] } cleave ;
{ 1 3 } [ cleave-test ] must-infer-as
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
-: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
-: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
\ exists? must-infer
\ (exists?) must-infer
+\ file-info must-infer
+\ link-info must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
delete-file
] if ;
-: to-directory over file-name append-path ;
+: to-directory ( from to -- from to' )
+ over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
-: find-last-sep swap [ memq? ] curry find-last drop ;
+: find-last-sep ( seq seps -- n )
+ swap [ memq? ] curry find-last drop ;
M: growable stream-read-until
[ find-last-sep ] keep over [
: a 1 ; inline
: b 2 ; inline
-: foo { a b } flags ;
+: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
-: ratio>float [ >bignum ] bi@ /f ;
+: ratio>float ( a b -- f ) [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
-: random-integer
+: random-integer ( -- n )
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;
{ 3 [ (a,b] ] }
} case ;
-: random-op
+: random-op ( -- pair )
{
{ + interval+ }
{ - interval- }
] when
random ;
-: interval-test
+: interval-test ( -- ? )
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
-: random-comparison
+: random-comparison ( -- pair )
{
{ < interval< }
{ <= interval<= }
{ >= interval>= }
} random ;
-: comparison-test
+: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [
C: <interval> interval
-: open-point f 2array ;
+: open-point ( n -- endpoint ) f 2array ;
-: closed-point t 2array ;
+: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ;
[ interval-to ] bi@ =
and and ;
-: (interval<) over interval-from over interval-from endpoint< ;
+: (interval<) ( i1 i2 -- i1 i2 ? )
+ over interval-from over interval-from endpoint< ;
: interval< ( i1 i2 -- ? )
{
SYMBOL: radix
SYMBOL: negative?
-: sign negative? get "-" "+" ? ;
+: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
} cond
] if ;
-: fold-if-branch? dup node-in-d first known-boolean-value? ;
+: fold-if-branch? ( node -- value ? )
+ dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
-: lift-branch
+: lift-branch ( node tail -- )
over
last-node clone-node
dup node-in-d \ #merge out-node
ABOUT: "parser"
-: $parsing-note
+: $parsing-note ( children -- )
drop
"This word should only be called from parsing words."
$notes ;
{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
HELP: parse-effect
-{ $values { "effect" "an instance of " { $link effect } } }
+{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
{ $description "Parses a stack effect from the current input line." }
-{ $examples "This word is used by " { $link POSTPONE: ( } " to parse stack effect declarations." }
+{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
$parsing-note ;
HELP: parse-base
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
+M: parsing-word stack-effect drop (( parsed -- parsed )) ;
+
: unexpected-eof ( word -- * ) f unexpected ;
: (parse-tokens) ( accum end -- accum )
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
- { [ dup parsing? ] [ nip execute-parsing t ] }
+ { [ dup parsing-word? ] [ nip execute-parsing t ] }
[ pick push drop t ]
} cond ;
lexer-factory get call (parse-lines) ;
! Parsing word utilities
-: parse-effect ( -- effect )
- ")" parse-tokens "(" over member? [
- "Stack effect declaration must not contain (" throw
- ] [
+: parse-effect ( end -- effect )
+ parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
] if
+ ] [
+ "Stack effect declaration must not contain ( or ((" throw
] if ;
ERROR: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE-WORD parse-definition ;
+: (:) ( -- word def ) CREATE-WORD parse-definition ;
SYMBOL: current-class
SYMBOL: current-generic
r> call
] with-scope ; inline
-: (M:)
+: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
- scan-word dup parsing?
+ scan-word dup parsing-word?
[ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
-float-arrays ;
+float-arrays combinators ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
+M: effect pprint* effect>string "(" swap ")" 3append text ;
+
: ?effect-height ( word -- n )
stack-effect [ effect-height ] [ 0 ] if* ;
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
- dup presented set
- dup parsing? over delimiter? rot t eq? or or
- [ bold font-style set ] when
+ [ presented set ]
+ [
+ [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
+ [ bold font-style set ] when
+ ] bi
] bind
] keep ;
<block swap pprint-word call block> ; inline
M: word pprint*
- dup parsing? [
+ dup parsing-word? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
- dup "break-before" word-prop line-break
- dup pprint-word
- dup ?start-group dup ?end-group
- "break-after" word-prop line-break
+ {
+ [ "break-before" word-prop line-break ]
+ [ pprint-word ]
+ [ ?start-group ]
+ [ ?end-group ]
+ [ "break-after" word-prop line-break ]
+ } cleave
] if ;
M: real pprint* number>string text ;
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
-combinators quotations sets ;
+combinators quotations sets accessors ;
: make-pprint ( obj quot -- block in use )
[
definer drop pprint-word ;
: stack-effect. ( word -- )
- dup parsing? over symbol? or not swap stack-effect and
+ [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
: word-synopsis ( word -- )
- dup seeing-word
- dup definer.
- dup pprint-word
- stack-effect. ;
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ stack-effect. ]
+ } cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup dispatch# pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ dispatch# pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "combination" word-prop hook-combination-var pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ "combination" word-prop hook-combination-var pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
- dup dup
- definer.
- "method-class" word-prop pprint-word
- "method-generic" word-prop pprint-word ;
+ [ definer. ]
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
- dup definer.
- dup mixin-instance-class pprint-word
- mixin-instance-mixin pprint-word ;
+ [ definer. ]
+ [ class>> pprint-word ]
+ [ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
POSTPONE: flushable
} [ declaration. ] with each ;
-: pprint-; \ ; pprint-word ;
+: pprint-; ( -- ) \ ; pprint-word ;
: (see) ( spec -- )
<colon dup synopsis*
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
-: (<block) pprinter-stack get push ;
+: (<block) ( block -- ) pprinter-stack get push ;
-: <block f <block> (<block) ;
+: <block ( -- ) f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
SYMBOL: prev
SYMBOL: next
-: split-groups [ t , ] when ;
+: split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
-: reader-effect T{ effect f { "object" } { "value" } } ; inline
-
: reader-word ( name -- word )
- ">>" append reader-effect create-accessor ;
+ ">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
-: writer-effect T{ effect f { "value" "object" } { } } ; inline
-
: writer-word ( name -- word )
- "(>>" swap ")" 3append writer-effect create-accessor ;
+ "(>>" swap ")" 3append (( value object -- )) create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
-: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
-
: setter-word ( name -- word )
- ">>" prepend setter-effect create-accessor ;
+ ">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
-: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
-
: changer-word ( name -- word )
- "change-" prepend changer-effect create-accessor ;
+ "change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
{ $syntax "( inputs -- outputs )" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
-{ $notes "Recursive words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
+{ $notes "Words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
+
+HELP: ((
+{ $syntax "(( inputs -- outputs ))" }
+{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
+{ $description "Literal stack effect syntax." }
+{ $notes "Useful for meta-programming with " { $link define-declared } "." } ;
HELP: !
{ $syntax "! comment..." }
] define-syntax
"(" [
- parse-effect word
+ ")" parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
] define-syntax
+ "((" [
+ "))" parse-effect parsed
+ ] define-syntax
+
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
: thread-registered? ( thread -- ? )
id>> threads key? ;
-: check-unregistered
+: check-unregistered ( thread -- thread )
dup thread-registered?
[ "Thread already stopped" throw ] when ;
-: check-registered
+: check-registered ( thread -- thread )
dup thread-registered?
[ "Thread is not running" throw ] unless ;
SYMBOL: load-help?
-: source-was-loaded t swap set-vocab-source-loaded? ;
+: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ;
-: source-wasn't-loaded f swap set-vocab-source-loaded? ;
+: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ;
: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
[ vocab-source-path [ bootstrap-file ] when* ] keep
source-was-loaded ;
-: docs-were-loaded t swap set-vocab-docs-loaded? ;
+: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ;
-: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
+: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ;
: load-docs ( vocab -- )
load-help? get [
{ $values { "word" word } { "target" word } }
{ $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ;
-HELP: parsing?
+HELP: parsing-word?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
-: parsing? ( obj -- ? )
- dup word? [ "parsing" word-prop ] [ drop f ] if ;
+PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
M: word literalize <wrapper> ;
-: ?word-name dup word? [ word-name ] when ;
+: ?word-name ( word -- name ) dup word? [ word-name ] when ;
: xref-words ( -- ) all-words [ xref ] each ;
parser vocabs.loader ;
IN: bootstrap.help
-: load-help
+: load-help ( -- )
"alien.syntax" require
"compiler" require
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
-accessors combinators locals classes.tuple math.order ;
+accessors combinators locals classes.tuple math.order
+memoize ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
-: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
+MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
: years ( n -- dt ) instant swap >>year ;
: months ( n -- dt ) instant swap >>month ;
: days ( n -- dt ) instant swap >>day ;
M: duration time-
before time+ ;
-: <zero> 0 0 0 0 0 0 instant <timestamp> ;
+MEMO: <zero> ( -- timestamp ) 0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone instant >>gmt-offset
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii ;
+memoize debugger io.encodings.ascii effects ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: define-objc-class-word ( name quot -- )
[
over , , \ unless-defined , dup , \ objc-class ,
- ] [ ] make >r "cocoa.classes" create r> define ;
+ ] [ ] make >r "cocoa.classes" create r>
+ (( -- class )) define-declared ;
: import-objc-class ( name quot -- )
2dup unless-defined
\r
C: <linked-error> linked-error\r
\r
-: ?linked dup linked-error? [ rethrow ] when ;\r
+: ?linked ( message -- message )\r
+ dup linked-error? [ rethrow ] when ;\r
\r
TUPLE: linked-thread < thread supervisor ;\r
\r
M: thread send ( message thread -- )\r
check-registered mailbox-of mailbox-put ;\r
\r
-: my-mailbox self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ;\r
\r
: receive ( -- message )\r
my-mailbox mailbox-get ?linked ;\r
SYMBOL: event-stream-callbacks
-: event-stream-counter \ event-stream-counter counter ;
+: event-stream-counter ( -- n )
+ \ event-stream-counter counter ;
[
event-stream-callbacks global
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel math models namespaces sequences strings
-splitting combinators unicode.categories math.order ;
+splitting combinators unicode.categories math.order accessors ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
V{ "" } clone <model> V{ } clone
{ set-delegate set-document-locs } document construct ;
-: add-loc document-locs push ;
+: add-loc ( loc document -- ) locs>> push ;
-: remove-loc document-locs delete ;
+: remove-loc ( loc document -- ) locs>> delete ;
: update-locs ( loc document -- )
document-locs [ set-model ] with each ;
>r >r first2 swap r> doc-line r> call
r> =col ; inline
-: ((word-elt)) [ ?nth blank? ] 2keep ;
+: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
[ >r blank? r> xor ] curry ; inline
[ file>> path>> ] [ line>> ] bi edit-location
] when* ;
-: fix ( word -- )
- [ "Fixing " write pprint " and all usages..." print nl ]
- [ [ smart-usage ] keep prefix ] bi
+: edit-each ( seq -- )
[
[ "Editing " write . ]
[
readln
] bi
] all? drop ;
+
+: fix ( word -- )
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ smart-usage ] keep prefix ] bi
+ edit-each ;
QUALIFIED: namespaces
IN: fry
-: , "Only valid inside a fry" throw ;
-: @ "Only valid inside a fry" throw ;
-: _ "Only valid inside a fry" throw ;
+: , ( -- * ) "Only valid inside a fry" throw ;
+: @ ( -- * ) "Only valid inside a fry" throw ;
+: _ ( -- * ) "Only valid inside a fry" throw ;
DEFER: (shallow-fry)
M: word article-name word-name ;
M: word article-title
- dup parsing? over symbol? or [
+ dup [ parsing-word? ] [ symbol? ] bi or [
word-name
] [
- dup word-name
- swap stack-effect
- [ effect>string " " swap 3append ] when*
+ [ word-name ]
+ [ stack-effect [ effect>string " " prepend ] [ "" if ] if* ] bi
+ append
] if ;
M: word article-content
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
-: (:help-multi)
- "This error has multiple delegates:" print
- ($index) nl
- "Use \\ ... help to get help about a specific delegate." print ;
-
-: (:help-none)
- drop "No help for this error. " print ;
-
-: (:help-debugger)
+: :help-debugger ( -- )
nl
"Debugger commands:" print
nl
":vars - list all variables at error time" print ;
: :help ( -- )
- error get delegates [ error-help ] map sift
- {
- { [ dup empty? ] [ (:help-none) ] }
- { [ dup length 1 = ] [ first help ] }
- [ (:help-multi) ]
- } cond (:help-debugger) ;
+ error get error-help [ help ] [ "No help for this error. " print ] if
+ :help-debugger ;
: remove-article ( name -- )
dup articles get key? [
SYMBOL: block
SYMBOL: table
-: last-span? last-element get span eq? ;
-: last-block? last-element get block eq? ;
+: last-span? ( -- ? ) last-element get span eq? ;
+: last-block? ( -- ? ) last-element get block eq? ;
: ($span) ( quot -- )
last-block? [ nl ] when
! Some spans
-: $snippet [ snippet-style get print-element* ] ($span) ;
+: $snippet ( children -- )
+ [ snippet-style get print-element* ] ($span) ;
-: $emphasis [ emphasis-style get print-element* ] ($span) ;
+: $emphasis ( children -- )
+ [ emphasis-style get print-element* ] ($span) ;
-: $strong [ strong-style get print-element* ] ($span) ;
+: $strong ( children -- )
+ [ strong-style get print-element* ] ($span) ;
-: $url [ url-style get print-element* ] ($span) ;
+: $url ( children -- )
+ [ url-style get print-element* ] ($span) ;
-: $nl nl nl drop ;
+: $nl ( children -- )
+ nl nl drop ;
! Some blocks
-: ($heading)
+: ($heading) ( children quot -- )
last-element get [ nl ] when ($block) ; inline
: $heading ( element -- )
M: string ($instance)
dup a/an write bl $snippet ;
-: $instance first ($instance) ;
+: $instance ( children -- ) first ($instance) ;
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
drop
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
-: $low-level-note
+: $low-level-note ( children -- )
drop
"Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
-: $values-x/y
+: $values-x/y ( children -- )
drop { { "x" number } { "y" number } } $values ;
-: $io-error
+: $io-error ( children -- )
drop
"Throws an error if the I/O operation fails." $errors ;
-: $prettyprinting-note
+: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
{ $link with-pprint } " combinator."
: <foo> "<" swap ">" 3append ;
-: empty-effect T{ effect f 0 0 } ;
-
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap [ <foo> write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
: <foo "<" prepend ;
#! Return the name and code for the <foo patterned
#! word.
<foo dup [ write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
: foo> ">" append ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
- foo> [ ">" write-html ] empty-effect html-word ;
+ foo> [ ">" write-html ] (( -- )) html-word ;
: </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup [ write-html ] curry empty-effect html-word ;
+ </foo> dup [ write-html ] curry (( -- )) html-word ;
: <foo/> "<" swap "/>" 3append ;
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap [ <foo/> write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
: foo/> "/>" append ;
: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
#! word.
- foo/> [ "/>" write-html ] empty-effect html-word ;
+ foo/> [ "/>" write-html ] (( -- )) html-word ;
: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
present escape-quoted-string write-html
"'" write-html ;
-: attribute-effect T{ effect f { "string" } 0 } ;
-
: define-attribute-word ( name -- )
dup "=" prepend swap
- [ write-attr ] curry attribute-effect html-word ;
+ [ write-attr ] curry (( string -- )) html-word ;
! Define some closed HTML tags
[
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit boa ] 2curry dupd curry define ;
+ [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ;
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
<PRIVATE
-: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
-: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
+: ?reader ( handle/f -- stream )
+ [ <input-port> &dispose ] [ input-stream get ] if* ;
+
+: ?writer ( handle/f -- stream )
+ [ <output-port> &dispose ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
SYMBOL: port-override
-: (port) port-override get swap or ;
+: (port) ( port -- port' ) port-override get swap or ;
PRIVATE>
[ >r >r underlying-handle r> r> redirect ]
} cond ;
-: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
+: ?closed ( obj -- obj' )
+ dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( process -- process )
dup stdin>> ?closed read-flags 0 redirect
: init-fdset ( fds fdset -- )
[ >r t swap munge r> set-nth ] curry each ;
-: read-fdset/tasks
+: read-fdset/tasks ( mx -- seq fdset )
[ reads>> keys ] [ read-fdset>> ] bi ;
-: write-fdset/tasks
+: write-fdset/tasks ( mx -- seq fdset )
[ writes>> keys ] [ write-fdset>> ] bi ;
: max-fd ( assoc -- n )
GENERIC: local-rewrite* ( obj -- )
-: lambda-rewrite
+: lambda-rewrite ( quot -- quot' )
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
let-rewrite ;
: parse-locals ( -- vars assoc )
- parse-effect
+ ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals dup push-locals ;
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
-: (M::)
+: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
-: saver \ >r <repetition> >quotation ;
+: saver ( n -- quot ) \ >r <repetition> >quotation ;
-: restorer \ r> <repetition> >quotation ;
+: restorer ( n -- quot ) \ r> <repetition> >quotation ;
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences classes.tuple
-combinators macros assocs math ;
+combinators macros assocs math effects ;
IN: match
SYMBOL: _
: define-match-var ( name -- )
create-in
dup t "match-var" set-word-prop
- dup [ get ] curry define ;
+ dup [ get ] curry (( -- value )) define-declared ;
: define-match-vars ( seq -- )
[ define-match-var ] each ;
gcd nip
] unit-test
-: verify-gcd
+: verify-gcd ( a b -- ? )
2dup gcd
>r rot * swap rem r> = ;
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
-: invalidate-memoized ! ( inputs... word )
+: invalidate-memoized ( inputs... word -- )
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
: <history> ( value -- history )
history construct-model dup reset-history ;
-: (add-history)
+: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
splitting words byte-arrays assocs combinators.lib ;
IN: opengl
-: coordinates [ first2 ] bi@ ;
+: coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 ] bi@ ;
-: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ;
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
-: (gl-poly) [ [ gl-vertex ] each ] do-state ;
+: (gl-poly) ( points state -- )
+ [ [ gl-vertex ] each ] do-state ;
: gl-fill-poly ( points -- )
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
: gl-poly ( points -- )
GL_LINE_LOOP (gl-poly) ;
-: circle-steps dup length v/n 2 pi * v*n ;
+: circle-steps ( steps -- angles )
+ dup length v/n 2 pi * v*n ;
-: unit-circle dup [ sin ] map swap [ cos ] map ;
+: unit-circle ( angles -- points1 points2 )
+ [ [ sin ] map ] [ [ cos ] map ] bi ;
-: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
+: adjust-points ( points1 points2 -- points1' points2' )
+ [ [ 1 + 0.5 * ] map ] bi@ ;
-: scale-points zip [ v* ] with map [ v+ ] with map ;
+: scale-points ( loc dim points1 points2 -- points )
+ zip [ v* ] with map [ v+ ] with map ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: <sprite> ( loc dim dim2 -- sprite )
f f sprite boa ;
-: sprite-size2 sprite-dim2 first2 ;
+: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
-: sprite-width sprite-dim first ;
+: sprite-width ( sprite -- w ) sprite-dim first ;
: gray-texture ( sprite pixmap -- id )
gen-texture [
TUPLE: bio handle disposed ;
-: <bio> f bio boa ;
+: <bio> ( handle -- bio ) f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
TUPLE: rsa handle disposed ;
-: <rsa> f rsa boa ;
+: <rsa> ( handle -- rsa ) f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
assocs sequences.private optimizer.specializers generic
-combinators sorting math quotations ;
+combinators sorting math quotations accessors ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
: effect-str ( node -- str )
[
- " " over node-in-d values%
- " r: " over node-in-r values%
+ " " over in-d>> values%
+ " r: " over in-r>> values%
" --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
+ " " over out-d>> values%
+ " r: " swap out-r>> values%
] "" make rest ;
MACRO: match-choose ( alist -- )
} match-choose ;
M: #shuffle node>quot
- dup node-in-d over node-out-d pretty-shuffle
+ dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
[ , ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " prepend comment, ;
-: pushed-literals node-out-d [ value-literal literalize ] map ;
+: pushed-literals ( node -- seq )
+ out-d>> [ value-literal literalize ] map ;
M: #push node>quot nip pushed-literals % ;
DEFER: dataflow>quot
: #call>quot ( ? node -- )
- dup node-param dup ,
+ dup param>> dup ,
[ dup effect-str ] [ "empty call" ] if comment, ;
M: #call node>quot #call>quot ;
M: #label node>quot
[
- dup node-param literalize ,
+ dup param>> literalize ,
dup #label-loop? "#loop: " "#label: " ?
- over node-param word-name append comment,
+ over param>> word-name append comment,
] 2keep
node-child swap dataflow>quot , \ call , ;
M: #if node>quot
[ "#if" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map %
+ children>> swap [ dataflow>quot ] curry map %
\ if , ;
M: #dispatch node>quot
[ "#dispatch" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map ,
+ children>> swap [ dataflow>quot ] curry map ,
\ dispatch , ;
-M: #>r node>quot nip
node-in-d length \ >r <array> % ;
+M: #>r node>quot nip
in-d>> length \ >r <array> % ;
-M: #r> node>quot nip
node-out-d length \ r> <array> % ;
+M: #r> node>quot nip
out-d>> length \ r> <array> % ;
M: object node>quot
[
dup class word-name %
" " %
- dup node-param unparse %
+ dup param>> unparse %
" " %
dup effect-str %
] "" make comment, ;
: (dataflow>quot) ( ? node -- )
dup [
- 2dup node>quot node-successor (dataflow>quot)
+ 2dup node>quot successor>> (dataflow>quot)
] [
2drop
] if ;
0 swap [
>r 1+ r>
dup #call? [
- node-param {
+ param>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
#! Syntax: QUALIFIED-WITH: vocab prefix
scan scan define-qualified ; parsing
-: expect=> scan "=>" assert= ;
+: expect=> ( -- ) scan "=>" assert= ;
: partial-vocab ( words name -- assoc )
dupd [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ,, building get peek push ;
-: v, V{ } clone , ;
-: ,v building get dup peek empty? [ dup pop* ] when drop ;
+: ,, ( obj -- ) building get peek push ;
+: v, ( -- ) V{ } clone , ;
+: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
my-boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
-: ?, [ , ] [ drop ] if ;
-
: bootstrap-profile ( -- profile )
- [
- "math" deploy-math? get ?,
- "compiler" deploy-compiler? get ?,
- "ui" deploy-ui? get ?,
- "io" native-io? ?,
- "random" deploy-random? get ?,
- ] { } make ;
+ {
+ { "math" deploy-math? }
+ { "compiler" deploy-compiler? }
+ { "ui" deploy-ui? }
+ { "random" deploy-random? }
+ } [ nip get ] assoc-filter keys
+ native-io? [ "io" suffix ] when ;
: staging-image-name ( profile -- name )
"staging."
{ 3 "Level 3 - Non-blocking streams and networking" }
} ;
-: strip-io? deploy-io get 1 = ;
+: strip-io? ( -- ? ) deploy-io get 1 = ;
-: native-io? deploy-io get 3 = ;
+: native-io? ( -- ? ) deploy-io get 3 = ;
SYMBOL: deploy-reflection
{ 6 "Level 6 - Full environment" }
} ;
-: strip-word-names? deploy-reflection get 2 < ;
-: strip-prettyprint? deploy-reflection get 3 < ;
-: strip-debugger? deploy-reflection get 4 < ;
-: strip-dictionary? deploy-reflection get 5 < ;
-: strip-globals? deploy-reflection get 6 < ;
+: strip-word-names? ( -- ? ) deploy-reflection get 2 < ;
+: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ;
+: strip-debugger? ( -- ? ) deploy-reflection get 4 < ;
+: strip-dictionary? ( -- ? ) deploy-reflection get 5 < ;
+: strip-globals? ( -- ? ) deploy-reflection get 6 < ;
SYMBOL: deploy-word-props?
SYMBOL: deploy-word-defs?
generic ;
IN: tools.disassembler
-: in-file "gdb-in.txt" temp-file ;
+: in-file ( -- path ) "gdb-in.txt" temp-file ;
-: out-file "gdb-out.txt" temp-file ;
+: out-file ( -- path ) "gdb-out.txt" temp-file ;
GENERIC: make-disassemble-cmd ( obj -- )
: (step-into-quot) ( quot -- ) add-breakpoint call ;
-: (step-into-if) ? (step-into-quot) ;
+: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-: (step-into-dispatch) nth (step-into-quot) ;
+: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
{
\ (step-into-execute) t "step-into?" set-word-prop
-: (step-into-continuation)
+: (step-into-continuation) ( -- )
continuation callstack >>call break ;
! Messages sent to walker thread
! For convenience
IN: syntax
-: B break ;
+: B ( -- ) break ;
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard boa ;
+: <clipboard> ( -- clipboard ) "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
2drop
] if ;
-: com-copy clipboard get gadget-copy ;
+: com-copy ( gadget -- ) clipboard get gadget-copy ;
-: com-copy-selection selection get gadget-copy ;
+: com-copy-selection ( gadget -- ) selection get gadget-copy ;
arrays assocs ;
IN: ui.commands
-: command-map-row
+: command-map-row ( children -- seq )
[
- dup first gesture>string ,
- second dup command-name ,
- dup command-word \ $link swap 2array ,
- command-description ,
- ] [ ] make ;
+ [ first gesture>string , ]
+ [
+ second
+ [ command-name , ]
+ [ command-word \ $link swap 2array , ]
+ [ command-description , ]
+ tri
+ ] bi
+ ] { } make ;
: command-map. ( command-map -- )
[ command-map-row ] map
$table ;
: $command-map ( element -- )
- first2
- dup (command-name) " commands" append $heading
- swap command-map
- dup command-map-blurb print-element command-map. ;
+ [ second (command-name) " commands" append $heading ]
+ [
+ first2 swap command-map
+ [ command-map-blurb print-element ] [ command-map. ] bi
+ ] bi ;
: $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.commands ui.gadgets ui.gadgets.borders
+USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
C: <button-paint> button-paint
-: find-button [ [ button? ] is? ] find-parent ;
+: find-button ( gadget -- button )
+ [ [ button? ] is? ] find-parent ;
: button-paint ( button paint -- button paint )
over find-button {
: toggle-model ( model -- )
[ not ] change-model ;
-: checkbox-theme
- f over set-gadget-interior
- { 5 5 } over set-pack-gap
- 1/2 swap set-pack-align ;
+: checkbox-theme ( gadget -- )
+ f >>interior
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
TUPLE: checkbox ;
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
-: radio-button-theme
- { 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
+: radio-button-theme ( gadget -- )
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right
[ <button> ] <radio-control>
dup radio-button-theme ;
-: radio-buttons-theme
- { 5 5 } swap set-pack-gap ;
+: radio-buttons-theme ( gadget -- )
+ { 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
-: contents-changed
+: contents-changed ( model editor -- )
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
-: caret/mark-changed
+: caret/mark-changed ( model editor -- )
nip editor-self dup relayout-1 scroll>caret ;
M: editor model-changed
[ drop dup extend-selection dup editor-mark click-loc ]
[ select-elt ] if ;
-: insert-newline "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input ;
-: delete-next-character T{ char-elt } editor-delete ;
+: delete-next-character ( editor -- )
+ T{ char-elt } editor-delete ;
-: delete-previous-character T{ char-elt } editor-backspace ;
+: delete-previous-character ( editor -- )
+ T{ char-elt } editor-backspace ;
-: delete-previous-word T{ word-elt } editor-delete ;
+: delete-previous-word ( editor -- )
+ T{ word-elt } editor-delete ;
-: delete-next-word T{ word-elt } editor-backspace ;
+: delete-next-word ( editor -- )
+ T{ word-elt } editor-backspace ;
-: delete-to-start-of-line T{ one-line-elt } editor-delete ;
+: delete-to-start-of-line ( editor -- )
+ T{ one-line-elt } editor-delete ;
-: delete-to-end-of-line T{ one-line-elt } editor-backspace ;
+: delete-to-end-of-line ( editor -- )
+ T{ one-line-elt } editor-backspace ;
editor "general" f {
{ T{ key-down f f "DELETE" } delete-next-character }
{ T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
} define-command-map
-: paste clipboard get paste-clipboard ;
+: paste ( editor -- ) clipboard get paste-clipboard ;
-: paste-selection selection get paste-clipboard ;
+: paste-selection ( editor -- ) selection get paste-clipboard ;
-: cut clipboard get editor-cut ;
+: cut ( editor -- ) clipboard get editor-cut ;
editor "clipboard" f {
{ T{ paste-action } paste }
T{ char-elt } editor-next
] if ;
-: previous-line T{ line-elt } editor-prev ;
+: previous-line ( editor -- ) T{ line-elt } editor-prev ;
-: next-line T{ line-elt } editor-next ;
+: next-line ( editor -- ) T{ line-elt } editor-next ;
-: previous-word T{ word-elt } editor-prev ;
+: previous-word ( editor -- ) T{ word-elt } editor-prev ;
-: next-word T{ word-elt } editor-next ;
+: next-word ( editor -- ) T{ word-elt } editor-next ;
-: start-of-line T{ one-line-elt } editor-prev ;
+: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-: end-of-line T{ one-line-elt } editor-next ;
+: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
editor "caret-motion" f {
{ T{ button-down } position-caret }
{ T{ key-down f { C+ } "END" } end-of-document }
} define-command-map
-: select-all T{ doc-elt } select-elt ;
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
-: select-line T{ one-line-elt } select-elt ;
+: select-line ( editor -- ) T{ one-line-elt } select-elt ;
-: select-word T{ one-word-elt } select-elt ;
+: select-word ( editor -- ) T{ one-word-elt } select-elt ;
: selected-word ( editor -- string )
dup gadget-selection?
[ dup select-word ] unless
gadget-selection ;
-: select-previous-character T{ char-elt } editor-select-prev ;
+: select-previous-character ( editor -- )
+ T{ char-elt } editor-select-prev ;
-: select-next-character T{ char-elt } editor-select-next ;
+: select-next-character ( editor -- )
+ T{ char-elt } editor-select-next ;
-: select-previous-line T{ line-elt } editor-select-prev ;
+: select-previous-line ( editor -- )
+ T{ line-elt } editor-select-prev ;
-: select-next-line T{ line-elt } editor-select-next ;
+: select-next-line ( editor -- )
+ T{ line-elt } editor-select-next ;
-: select-previous-word T{ word-elt } editor-select-prev ;
+: select-previous-word ( editor -- )
+ T{ word-elt } editor-select-prev ;
-: select-next-word T{ word-elt } editor-select-next ;
+: select-next-word ( editor -- )
+ T{ word-elt } editor-select-next ;
-: select-start-of-line T{ one-line-elt } editor-select-prev ;
+: select-start-of-line ( editor -- )
+ T{ one-line-elt } editor-select-prev ;
-: select-end-of-line T{ one-line-elt } editor-select-next ;
+: select-end-of-line ( editor -- )
+ T{ one-line-elt } editor-select-next ;
-: select-start-of-document T{ doc-elt } editor-select-prev ;
+: select-start-of-document ( editor -- )
+ T{ doc-elt } editor-select-prev ;
-: select-end-of-document T{ doc-elt } editor-select-next ;
+: select-end-of-document ( editor -- )
+ T{ doc-elt } editor-select-next ;
editor "selection" f {
{ T{ button-down f { S+ } } extend-selection }
! gadgets gets left-over space.
TUPLE: frame ;
-: <frame-grid> 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
: @center 1 1 ;
: @left 0 1 ;
dup gadget-layout-state
[ drop ] [ dup invalidate layout-later ] if ;
-: show-gadget t swap set-gadget-visible? ;
+: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
-: hide-gadget f swap set-gadget-visible? ;
+: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
: (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim =
dup [ layout ] each-child
] when drop ;
-: graft-queue \ graft-queue get ;
+: graft-queue ( -- dlist ) \ graft-queue get ;
: unqueue-graft ( gadget -- )
graft-queue over gadget-graft-node delete-node
SYMBOL: in-layout?
-: not-in-layout
+: not-in-layout ( -- )
in-layout? get
[ "Cannot add/remove gadgets in layout*" throw ] when ;
: pref-dim-grid ( grid -- dims )
grid-children [ [ pref-dim ] map ] map ;
-: (compute-grid) [ max-dim ] map ;
+: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
{ 0.65 0.45 1.0 1.0 }
} } swap set-gadget-interior ;
-: <title-label> <label> dup title-theme ;
+: <title-label> ( text -- label ) <label> dup title-theme ;
: <title-bar> ( title quot -- gadget )
[
selection-color caret mark selecting? ;
: clear-selection ( pane -- )
- f over set-pane-caret
- f swap set-pane-mark ;
+ f >>caret
+ f >>mark
+ drop ;
-: add-output 2dup set-pane-output add-gadget ;
+: add-output ( current pane -- )
+ [ set-pane-output ] [ add-gadget ] 2bi ;
-: add-current 2dup set-pane-current add-gadget ;
+: add-current ( current pane -- )
+ [ set-pane-current ] [ add-gadget ] 2bi ;
: prepare-line ( pane -- )
- dup clear-selection
- dup pane-prototype clone swap add-current ;
+ [ clear-selection ]
+ [ [ pane-prototype clone ] keep add-current ] bi ;
: pane-caret&mark ( pane -- caret mark )
- dup pane-caret swap pane-mark ;
+ [ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
selected-children gadget-text ;
: pane-clear ( pane -- )
- dup clear-selection
- dup pane-output clear-incremental
- pane-current clear-gadget ;
+ [ clear-selection ]
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ tri ;
-: pane-theme ( editor -- )
- selection-color swap set-pane-selection-color ;
+: pane-theme ( pane -- )
+ selection-color >>selection-color drop ;
: <pane> ( -- pane )
pane new
<pile> over set-delegate
- <shelf> over set-pane-prototype
+ <shelf> >>prototype
<pile> <incremental> over add-output
dup prepare-line
dup pane-theme ;
: overrun? ( width -- ? ) x get + margin get > ;
-: zero-vars [ 0 swap set ] each ;
+: zero-vars ( seq -- ) [ 0 swap set ] each ;
: wrap-line ( -- )
line-height get y +@
: find-scroller ( gadget -- scroller/f )
[ [ scroller? ] is? ] find-parent ;
-: scroll-up-page scroller-y -1 swap slide-by-page ;
+: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
-: scroll-down-page scroller-y 1 swap slide-by-page ;
+: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
-: scroll-up-line scroller-y -1 swap slide-by-line ;
+: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
-: scroll-down-line scroller-y 1 swap slide-by-line ;
+: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
scroll-direction get-global first2
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-: x-model g gadget-model model-dependencies first ;
+: x-model ( -- model ) g gadget-model model-dependencies first ;
-: y-model g gadget-model model-dependencies second ;
+: y-model ( -- model ) g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [
: min-thumb-dim 15 ;
-: slider-value gadget-model range-value >fixnum ;
+: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-: slider-page gadget-model range-page-value ;
+: slider-page ( gadget -- n ) gadget-model range-page-value ;
-: slider-max gadget-model range-max-value ;
+: slider-max ( gadget -- n ) gadget-model range-max-value ;
-: slider-max* gadget-model range-max-value* ;
+: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
dup elevator-length over thumb-dim - 1 max
swap slider-max* 1 max / ;
-: slider>screen slider-scale * ;
+: slider>screen ( m scale -- n ) slider-scale * ;
-: screen>slider slider-scale / ;
+: screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ;
swap <thumb> g-> set-slider-thumb over add-gadget
@center frame, ;
-: <left-button> { 0 1 } arrow-left -1 <slide-button> ;
-: <right-button> { 0 1 } arrow-right 1 <slide-button> ;
+: <left-button> ( -- button )
+ { 0 1 } arrow-left -1 <slide-button> ;
+
+: <right-button> ( -- button )
+ { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- )
[
<right-button> @right frame,
] with-gadget ;
-: <up-button> { 1 0 } arrow-up -1 <slide-button> ;
-: <down-button> { 1 0 } arrow-down 1 <slide-button> ;
+: <up-button> ( -- button )
+ { 1 0 } arrow-up -1 <slide-button> ;
+
+: <down-button> ( -- button )
+ { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- )
[
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
colors ;
IN: ui.gadgets.theme
-: solid-interior <solid> swap set-gadget-interior ;
+: solid-interior ( gadget color -- )
+ <solid> swap set-gadget-interior ;
-: solid-boundary <solid> swap set-gadget-boundary ;
+: solid-boundary ( gadget color -- )
+ <solid> swap set-gadget-boundary ;
-: faint-boundary gray solid-boundary ;
+: faint-boundary ( gadget -- )
+ gray solid-boundary ;
-: selection-color light-purple ;
+: selection-color ( -- color ) light-purple ;
: plain-gradient
T{ gradient f {
TUPLE: viewport ;
-: find-viewport [ viewport? ] find-parent ;
+: find-viewport ( gadget -- viewport )
+ [ viewport? ] find-parent ;
: viewport-dim ( viewport -- dim )
gadget-child pref-dim viewport-gap 2 v*n v+ ;
fonts handle
loc ;
-: find-world [ world? ] find-parent ;
+: find-world ( gadget -- world ) [ world? ] find-parent ;
M: f world-status ;
C: <solid> solid
! Solid pen
-: (solid)
+: (solid) ( gadget paint -- loc dim )
solid-color gl-color rect-dim >r origin get dup r> v+ ;
M: solid draw-interior (solid) gl-fill-rect ;
USING: debugger ui.tools.workspace help help.topics kernel
models ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs ;
+ui.gadgets.buttons compiler.units assocs words vocabs
+accessors ;
IN: ui.tools.browser
TUPLE: browser-gadget pane history ;
: show-help ( link help -- )
- dup browser-gadget-history add-history
- >r >link r> browser-gadget-history set-model ;
+ dup history>> add-history
+ >r >link r> history>> set-model ;
: <help-pane> ( browser-gadget -- gadget )
- browser-gadget-history
- [ [ dup help ] try drop ] <pane-control> ;
+ history>> [ [ dup help ] try drop ] <pane-control> ;
: init-history ( browser-gadget -- )
- "handbook" >link <history>
- swap set-browser-gadget-history ;
+ "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
browser-gadget new
M: browser-gadget call-tool* show-help ;
M: browser-gadget tool-scroller
- browser-gadget-pane find-scroller ;
+ pane>> find-scroller ;
M: browser-gadget graft*
dup add-definition-observer
or or ;
M: browser-gadget definitions-changed ( assoc browser -- )
- browser-gadget-history
+ history>>
dup model-value rot showing-definition?
[ notify-connections ] [ drop ] if ;
: help-action ( browser-gadget -- link )
- browser-gadget-history model-value >link ;
+ history>> model-value >link ;
-: com-follow browser-gadget call-tool ;
+: com-follow ( link -- ) browser-gadget call-tool ;
-: com-back browser-gadget-history go-back ;
+: com-back ( browser -- ) history>> go-back ;
-: com-forward browser-gadget-history go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
-: com-documentation "handbook" swap show-help ;
+: com-documentation ( browser -- ) "handbook" swap show-help ;
-: com-vocabularies "vocab-index" swap show-help ;
+: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-: browser-help "ui-browser" help-window ;
+: browser-help ( -- ) "ui-browser" help-window ;
\ browser-help H{ { +nullary+ t } } define-command
{ T{ button-down } request-focus }
} define-command-map
-: com-traceback error-continuation get traceback-window ;
+: com-traceback ( -- ) error-continuation get traceback-window ;
\ com-traceback H{ { +nullary+ t } } define-command
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system ;
+tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ;
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
-: deploy-settings-theme
- { 10 10 } over set-pack-gap
- 1 swap set-pack-fill ;
+: deploy-settings-theme ( gadget -- )
+ { 10 10 } >>gap
+ 1 >>fill
+ drop ;
: <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map [
namespace <mapping> over set-gadget-model
] bind ;
-: find-deploy-gadget
+: find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ;
-: find-deploy-vocab
+: find-deploy-vocab ( gadget -- vocab )
find-deploy-gadget deploy-gadget-vocab ;
-: find-deploy-config
+: find-deploy-config ( gadget -- config )
find-deploy-vocab deploy-config ;
-: find-deploy-settings
+: find-deploy-settings ( gadget -- settings )
find-deploy-gadget deploy-gadget-settings ;
: com-revert ( gadget -- )
{ T{ key-down f f "RET" } com-deploy }
} define-command-map
-: buttons,
+: buttons, ( -- )
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
\ globals H{ { +nullary+ t } { +listener+ t } } define-command
-: inspector-help "ui-inspector" help-window ;
+: inspector-help ( -- ) "ui-inspector" help-window ;
\ inspector-help H{ { +nullary+ t } } define-command
listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
-: listener-help "ui-listener" help-window ;
+: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
-tools.vocabs classes compiler.units ;
+tools.vocabs classes compiler.units accessors ;
IN: ui.tools.operations
V{ } clone operations set-global
{ +listener+ t }
} define-operation
-: com-prettyprint . ;
+: com-prettyprint ( obj -- ) . ;
[ drop t ] \ com-prettyprint H{
{ +listener+ t }
} define-operation
-: com-push ;
+: com-push ( obj -- obj ) ;
[ drop t ] \ com-push H{
{ +listener+ t }
} define-operation
-: com-unparse unparse listener-input ;
+: com-unparse ( obj -- ) unparse listener-input ;
[ drop t ] \ com-unparse H{ } define-operation
! Input
-: com-input input-string listener-input ;
+: com-input ( obj -- ) string>> listener-input ;
[ input? ] \ com-input H{
{ +primary+ t }
} define-operation
! Pathnames
-: edit-file edit ;
+: edit-file ( pathname -- ) edit ;
[ pathname? ] \ edit-file H{
{ +keyboard+ T{ key-down f { C+ } "E" } }
} define-operation
! Vocabularies
-: com-vocab-words get-workspace swap show-vocab-words ;
+: com-vocab-words ( vocab -- )
+ get-workspace swap show-vocab-words ;
[ vocab? ] \ com-vocab-words H{
{ +secondary+ t }
{ +keyboard+ T{ key-down f { C+ } "B" } }
} define-operation
-: com-enter-in vocab-name set-in ;
+: com-enter-in ( vocab -- ) vocab-name set-in ;
[ vocab? ] \ com-enter-in H{
{ +keyboard+ T{ key-down f { C+ } "I" } }
{ +listener+ t }
} define-operation
-: com-use-vocab vocab-name use+ ;
+: com-use-vocab ( vocab -- ) vocab-name use+ ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }
{ +listener+ t }
} define-operation
-: com-show-profile profiler-gadget call-tool ;
+: com-show-profile ( workspace -- )
+ profiler-gadget call-tool ;
: com-profile ( quot -- ) profile f com-show-profile ;
: com-method-profile ( gadget -- )
[ method-profile. ] with-profiler-pane ;
-: profiler-help "ui-profiler" help-window ;
+: profiler-help ( -- ) "ui-profiler" help-window ;
\ profiler-help H{ { +nullary+ t } } define-command
2drop t
] if ;
-: find-live-search [ [ live-search? ] is? ] find-parent ;
+: find-live-search ( gadget -- search )
+ [ [ live-search? ] is? ] find-parent ;
-: find-search-list find-live-search live-search-list ;
+: find-search-list ( gadget -- list )
+ find-live-search live-search-list ;
TUPLE: search-field ;
[ workspace-window ] ui-hook set-global
-: com-listener stack-display select-tool ;
+: com-listener ( workspace -- ) stack-display select-tool ;
-: com-browser browser-gadget select-tool ;
+: com-browser ( workspace -- ) browser-gadget select-tool ;
-: com-inspector inspector-gadget select-tool ;
+: com-inspector ( workspace -- ) inspector-gadget select-tool ;
-: com-profiler profiler-gadget select-tool ;
+: com-profiler ( workspace -- ) profiler-gadget select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
-: walker-help "ui-walker" help-window ;
+: walker-help ( -- ) "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
TUPLE: workspace book listener popup ;
-: find-workspace [ workspace? ] find-parent ;
+: find-workspace ( gadget -- workspace )
+ [ workspace? ] find-parent ;
SYMBOL: workspace-window-hook
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-: stat-st_atim stat-st_atimespec ;
-: stat-st_mtim stat-st_mtimespec ;
-: stat-st_ctim stat-st_ctimespec ;
+: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
+: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
+: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
-USING: kernel parser sequences words ;
+USING: kernel parser sequences words effects ;
IN: values
: VALUE:
- CREATE-WORD { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry
+ (( -- value )) define-declared ; parsing
: set-value ( value word -- )
word-def first set-first ;
projects / factor.git / commitdiff