Mandatory stack effect annotations
Slava Pestov
parent
3733624dcf
commit
9dd5c9919f
|
|
@ -5,7 +5,7 @@ assocs kernel kernel.private libc math
|
|||
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>
|
||||
|
|
@ -214,7 +214,8 @@ M: long-long-type box-return ( type -- )
|
|||
>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 )
|
||||
[
|
||||
|
|
@ -227,7 +228,8 @@ M: long-long-type box-return ( type -- )
|
|||
>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"
|
||||
|
|
|
|||
|
|
@ -216,7 +216,8 @@ M: alien-invoke-error summary
|
|||
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 )
|
||||
"@"
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@ USING: alien alien.c-types alien.strings parser threads words
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@ IN: bootstrap.compiler
|
|||
|
||||
enable-compiler
|
||||
|
||||
: compile-uncompiled [ compiled? not ] filter compile ;
|
||||
: compile-uncompiled ( words -- )
|
||||
[ compiled? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
|
|
|||
|
|
@ -85,13 +85,6 @@ SYMBOL: objects
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -203,9 +196,9 @@ GENERIC: ' ( obj -- ptr )
|
|||
|
||||
! 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.
|
||||
|
|
@ -248,15 +241,15 @@ M: float '
|
|||
|
||||
! 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
|
||||
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ IN: bootstrap.syntax
|
|||
"\""
|
||||
"#!"
|
||||
"("
|
||||
"(("
|
||||
":"
|
||||
";"
|
||||
"<PRIVATE"
|
||||
|
|
|
|||
|
|
@ -12,11 +12,11 @@ IN: classes.algebra.tests
|
|||
\ flatten-class must-infer
|
||||
\ flatten-builtin-class must-infer
|
||||
|
||||
: class= [ class<= ] [ swap class<= ] 2bi and ;
|
||||
: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
|
||||
|
||||
: class-and* >r class-and r> class= ;
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
|
||||
|
||||
: class-or* >r class-or r> class= ;
|
||||
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
|
||||
|
||||
[ t ] [ object object object class-and* ] unit-test
|
||||
[ t ] [ fixnum object fixnum class-and* ] unit-test
|
||||
|
|
@ -193,9 +193,9 @@ UNION: z1 b1 c1 ;
|
|||
[ f ] [ null { number fixnum null } min-class ] unit-test
|
||||
|
||||
! Test for hangs?
|
||||
: random-class classes random ;
|
||||
: random-class ( -- class ) classes random ;
|
||||
|
||||
: random-op
|
||||
: random-op ( -- word )
|
||||
{
|
||||
class-and
|
||||
class-or
|
||||
|
|
@ -211,13 +211,13 @@ UNION: z1 b1 c1 ;
|
|||
] unit-test
|
||||
] times
|
||||
|
||||
: random-boolean
|
||||
: random-boolean ( -- ? )
|
||||
{ t f } random ;
|
||||
|
||||
: boolean>class
|
||||
: boolean>class ( ? -- class )
|
||||
object null ? ;
|
||||
|
||||
: random-boolean-op
|
||||
: random-boolean-op ( -- word )
|
||||
{
|
||||
and
|
||||
or
|
||||
|
|
@ -225,9 +225,10 @@ UNION: z1 b1 c1 ;
|
|||
xor
|
||||
} random ;
|
||||
|
||||
: class-xor [ class-or ] 2keep class-and class-not class-and ;
|
||||
: class-xor ( cls1 cls2 -- cls3 )
|
||||
[ class-or ] 2keep class-and class-not class-and ;
|
||||
|
||||
: boolean-op>class-op
|
||||
: boolean-op>class-op ( word -- word' )
|
||||
{
|
||||
{ and class-and }
|
||||
{ or class-or }
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ INSTANCE: integer mx1
|
|||
[ \ mx1 forget ] with-compilation-unit
|
||||
|
||||
! Empty unions were causing problems
|
||||
GENERIC: empty-union-test
|
||||
GENERIC: empty-union-test ( obj -- obj )
|
||||
|
||||
UNION: empty-union-1 ;
|
||||
|
||||
|
|
@ -162,7 +162,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
|||
[ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ PREDICATE: tuple-class < class
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ columns math.order classes.private ;
|
|||
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 ;
|
||||
|
|
@ -69,7 +69,7 @@ C: <predicate-test> predicate-test
|
|||
PREDICATE: silly-pred < tuple
|
||||
class \ rect = ;
|
||||
|
||||
GENERIC: area
|
||||
GENERIC: area ( obj -- n )
|
||||
M: silly-pred area dup w>> swap h>> * ;
|
||||
|
||||
TUPLE: circle radius ;
|
||||
|
|
@ -164,7 +164,7 @@ C: <t4> t4
|
|||
[ 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 ;
|
||||
|
||||
|
|
@ -208,8 +208,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
|
||||
! We want to make sure constructors are recompiled when
|
||||
! tuples are reshaped
|
||||
: cons-test-1 \ erg's-reshape-problem 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
|
||||
|
||||
|
|
@ -242,7 +242,7 @@ C: <laptop> laptop
|
|||
[ 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
|
||||
|
|
@ -275,7 +275,7 @@ C: <server> server
|
|||
[ 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
|
||||
|
|
@ -375,7 +375,7 @@ C: <test2> test2
|
|||
|
||||
"a" "b" <test2> "test" set
|
||||
|
||||
: test-a/b
|
||||
: test-a/b ( -- )
|
||||
[ "a" ] [ "test" get a>> ] unit-test
|
||||
[ "b" ] [ "test" get b>> ] unit-test ;
|
||||
|
||||
|
|
@ -403,7 +403,7 @@ TUPLE: move-up-2 < move-up-1 c ;
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ SYMBOL: main-vocab-hook
|
|||
main-vocab-hook get [ call ] [ "listener" ] if*
|
||||
] if ;
|
||||
|
||||
: default-cli-args
|
||||
: default-cli-args ( -- )
|
||||
global [
|
||||
"quiet" off
|
||||
"script" off
|
||||
|
|
|
|||
|
|
@ -6,18 +6,20 @@ IN: compiler.constants
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -59,11 +59,11 @@ PRIVATE>
|
|||
[ 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 ] [
|
||||
|
|
|
|||
|
|
@ -252,7 +252,7 @@ cell 8 = [
|
|||
! Some randomized tests
|
||||
: compiled-fixnum* fixnum* ;
|
||||
|
||||
: test-fixnum*
|
||||
: test-fixnum* ( -- )
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
|
|
@ -262,7 +262,7 @@ cell 8 = [
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -271,7 +271,7 @@ cell 8 = [
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -377,7 +377,7 @@ cell 8 = [
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -69,31 +69,31 @@ IN: compiler.tests
|
|||
|
||||
! 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
|
||||
] [
|
||||
|
|
@ -102,7 +102,7 @@ IN: compiler.tests
|
|||
|
||||
[ 17 ] [ 10 dummy-if-6 ] unit-test
|
||||
|
||||
: dead-code-rec
|
||||
: dead-code-rec ( -- obj )
|
||||
t [
|
||||
3.2
|
||||
] [
|
||||
|
|
@ -111,11 +111,11 @@ IN: compiler.tests
|
|||
|
||||
[ 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
|
||||
|
|
@ -127,37 +127,37 @@ DEFER: countdown-b
|
|||
|
||||
[ ] [ 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
|
||||
|
|
@ -201,7 +201,7 @@ DEFER: countdown-b
|
|||
] 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 ;
|
||||
|
|
@ -214,13 +214,13 @@ M: integer single-combination-test drop ;
|
|||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ words splitting sorting ;
|
|||
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
|
||||
|
|
@ -17,9 +17,9 @@ words splitting sorting ;
|
|||
{ 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?
|
||||
|
|
@ -31,7 +31,7 @@ words splitting sorting ;
|
|||
\ > 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
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ unit-test
|
|||
|
||||
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
|
||||
|
||||
: foo ;
|
||||
: foo ( -- ) ;
|
||||
|
||||
[ 5 5 ]
|
||||
[ 1.2 [ tag [ foo ] keep ] compile-call ]
|
||||
|
|
@ -103,10 +103,10 @@ unit-test
|
|||
|
||||
|
||||
! 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 ] [
|
||||
|
|
@ -143,7 +143,7 @@ unit-test
|
|||
] unit-test
|
||||
|
||||
! Regression
|
||||
: foox
|
||||
: foox ( obj -- obj )
|
||||
dup not
|
||||
[ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
|
||||
|
||||
|
|
@ -189,7 +189,7 @@ TUPLE: my-tuple ;
|
|||
] unit-test
|
||||
|
||||
! Regression
|
||||
: a-dummy drop "hi" print ;
|
||||
: a-dummy ( -- ) drop "hi" print ;
|
||||
|
||||
[ ] [
|
||||
1 [
|
||||
|
|
@ -203,7 +203,7 @@ TUPLE: my-tuple ;
|
|||
] 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+ ]
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ SYMBOL: restarts
|
|||
#! with a declaration.
|
||||
f { object } declare ;
|
||||
|
||||
: init-catchstack V{ } clone 1 setenv ;
|
||||
: init-catchstack ( -- ) V{ } clone 1 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -41,12 +41,12 @@ HOOK: stack-frame cpu ( frame-size -- n )
|
|||
! 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 ( -- )
|
||||
|
|
@ -195,7 +195,7 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
|||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
: operand ( var -- op ) get v>operand ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ big-endian on
|
|||
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
|
||||
|
||||
: jit-call-quot ( -- )
|
||||
temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt
|
||||
temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt
|
||||
temp-reg MTCTR ! jump to quotation-xt
|
||||
BCTR ;
|
||||
|
||||
|
|
@ -93,7 +93,7 @@ big-endian on
|
|||
temp-reg ds-reg 0 LWZ ! load index
|
||||
temp-reg dup 1 SRAWI ! turn it into an array offset
|
||||
quot-reg dup temp-reg ADD ! compute quotation location
|
||||
quot-reg dup array-start LWZ ! load quotation
|
||||
quot-reg dup array-start-offset LWZ ! load quotation
|
||||
ds-reg dup 4 SUBI ! pop index
|
||||
jit-call-quot
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
|
||||
|
|
|
|||
|
|
@ -31,21 +31,23 @@ M: int-regs return-reg drop EAX ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -151,7 +153,7 @@ M: x86.32 %box ( n reg-class func -- )
|
|||
>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
|
||||
|
|
@ -166,7 +168,7 @@ M: x86.32 %box ( n reg-class func -- )
|
|||
|
||||
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 -- )
|
||||
|
|
@ -260,7 +262,7 @@ os windows? [
|
|||
4 "double" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
: sse2? "Intrinsic" throw ;
|
||||
: sse2? ( -- ? ) "Intrinsic" throw ;
|
||||
|
||||
\ sse2? [
|
||||
{ EAX EBX ECX EDX } [ PUSH ] each
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ sequences generic arrays generator generator.fixup
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@ generator generator.registers generator.fixup system layouts
|
|||
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 [+] ;
|
||||
|
||||
|
|
@ -36,14 +36,14 @@ GENERIC: load-return-reg ( stack@ reg-class -- )
|
|||
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 ;
|
||||
|
||||
|
|
@ -53,7 +53,7 @@ M: x86 stack-frame ( n -- i )
|
|||
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
|
||||
|
|
@ -120,7 +120,7 @@ M: x86 %peek [ v>operand ] bi@ MOV ;
|
|||
|
||||
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) ;
|
||||
|
||||
|
|
@ -139,7 +139,7 @@ M: x86 small-enough? ( n -- ? )
|
|||
|
||||
: %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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ IN: cpu.x86.assembler
|
|||
: define-registers ( names size -- )
|
||||
>r dup length r> [ define-register ] curry 2each ;
|
||||
|
||||
: REGISTERS:
|
||||
: REGISTERS: ( -- )
|
||||
scan-word ";" parse-tokens swap define-registers ; parsing
|
||||
|
||||
>>
|
||||
|
|
@ -76,31 +76,31 @@ TUPLE: indirect base index scale displacement ;
|
|||
|
||||
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 -- ? )
|
||||
|
||||
|
|
@ -145,10 +145,10 @@ GENERIC# n, 1 ( value n -- )
|
|||
|
||||
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 , ;
|
||||
|
|
@ -196,10 +196,10 @@ M: object operand-64? drop f ;
|
|||
[ 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
|
||||
|
|
@ -225,7 +225,7 @@ M: object operand-64? drop f ;
|
|||
#! 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 ;
|
||||
|
||||
|
|
@ -240,7 +240,7 @@ M: object operand-64? drop f ;
|
|||
#! '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 -- )
|
||||
|
|
@ -249,7 +249,7 @@ M: object operand-64? drop f ;
|
|||
: 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 -- )
|
||||
|
|
@ -320,38 +320,38 @@ M: operand MOV HEX: 88 2-operand ;
|
|||
|
||||
! 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 , ;
|
||||
|
||||
|
|
@ -399,8 +399,8 @@ M: operand CMP OCT: 070 2-operand ;
|
|||
: 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 ;
|
||||
|
|
@ -423,26 +423,26 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
|
|||
! 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
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ big-endian off
|
|||
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
|
||||
|
||||
[
|
||||
|
|
@ -70,8 +70,8 @@ big-endian off
|
|||
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
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -20,16 +20,16 @@ IN: cpu.x86.intrinsics
|
|||
} 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 [+] ;
|
||||
|
|
@ -399,15 +399,15 @@ IN: cpu.x86.intrinsics
|
|||
{ +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 -- )
|
||||
|
|
@ -429,7 +429,7 @@ IN: cpu.x86.intrinsics
|
|||
{ +clobber+ { "value" "offset" } }
|
||||
} ;
|
||||
|
||||
: define-setter
|
||||
: define-setter ( word reg -- )
|
||||
[ swap MOV ] swap
|
||||
[ %alien-integer-set ] 2curry
|
||||
alien-integer-set-template
|
||||
|
|
|
|||
|
|
@ -36,12 +36,12 @@ M: string error. print ;
|
|||
: :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 -- )
|
||||
[
|
||||
|
|
@ -143,15 +143,15 @@ M: relative-overflow summary
|
|||
: 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
|
||||
|
|
@ -161,7 +161,7 @@ PREDICATE: kernel-error < array
|
|||
[ second 0 15 between? ]
|
||||
} cond ;
|
||||
|
||||
: kernel-errors
|
||||
: kernel-errors ( error -- n errors )
|
||||
second {
|
||||
{ 0 [ expired-error. ] }
|
||||
{ 1 [ io-error. ] }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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? ;
|
||||
|
|
@ -11,14 +11,13 @@ 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 ;
|
||||
|
|
@ -34,10 +33,10 @@ M: integer (stack-picture) drop "object" ;
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -50,16 +49,16 @@ M: word stack-effect
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -72,8 +72,8 @@ GENERIC: generate-node ( node -- next )
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ INSTANCE: temp-reg value
|
|||
! 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 ;
|
||||
|
|
@ -78,7 +78,7 @@ M: ds-loc live-loc?
|
|||
! 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?
|
||||
|
|
@ -177,7 +177,7 @@ INSTANCE: constant value
|
|||
<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 {
|
||||
|
|
@ -231,7 +231,7 @@ GENERIC: finalize-height ( stack -- )
|
|||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc)
|
||||
: (loc) ( m stack -- n )
|
||||
#! Utility for methods on <loc>
|
||||
height>> - ;
|
||||
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ M: integer generic-forget-test-1 / ;
|
|||
[ 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 = ;
|
||||
|
||||
|
|
@ -174,7 +174,7 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
|||
\ 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 - ;
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ M: trivial-tuple-dispatch-engine engine>quot
|
|||
>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 )
|
||||
[
|
||||
|
|
@ -78,7 +78,7 @@ M: engine-word irrelevant? drop t ;
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ quotations inference vectors growable hashtables sbufs
|
|||
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 + ;
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ M: complex lo-tag-test sq ;
|
|||
[ -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 ;
|
||||
|
||||
|
|
@ -53,7 +53,7 @@ TUPLE: circle < shape radius ;
|
|||
|
||||
C: <circle> circle
|
||||
|
||||
GENERIC: area
|
||||
GENERIC: area ( shape -- n )
|
||||
|
||||
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
|
||||
|
||||
|
|
@ -63,15 +63,15 @@ M: circle area radius>> sq pi * ;
|
|||
[ 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>> ]
|
||||
|
|
@ -83,7 +83,7 @@ M: circle perimiter 2 * pi * ;
|
|||
[ 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" ;
|
||||
|
||||
|
|
@ -125,7 +125,7 @@ M: circle big-mix-test drop "circle" ;
|
|||
[ "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" ;
|
||||
|
||||
|
|
@ -226,7 +226,7 @@ M: b funky* "b" , call-next-method ;
|
|||
|
||||
M: c funky* "c" , call-next-method ;
|
||||
|
||||
: funky [ funky* ] { } make ;
|
||||
: funky ( obj -- seq ) [ funky* ] { } make ;
|
||||
|
||||
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
|
||||
|
||||
|
|
@ -293,7 +293,7 @@ M: sbuf no-stack-effect-decl ;
|
|||
TUPLE: xref-tuple-1 ;
|
||||
TUPLE: xref-tuple-2 < xref-tuple-1 ;
|
||||
|
||||
: (xref-test) drop ;
|
||||
: (xref-test) ( obj -- ) drop ;
|
||||
|
||||
GENERIC: xref-test ( obj -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -43,9 +43,9 @@ HELP: consume/produce
|
|||
{ $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
|
||||
|
|
@ -61,8 +61,8 @@ HELP: effect-error
|
|||
{ $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." }
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ M: word inline?
|
|||
|
||||
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 ] [
|
||||
|
|
@ -382,18 +382,36 @@ TUPLE: unbalanced-branches-error quots in out ;
|
|||
#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
|
||||
|
|
@ -412,7 +430,7 @@ TUPLE: effect-error word 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
|
||||
|
|
@ -424,18 +442,16 @@ TUPLE: effect-error word effect ;
|
|||
: 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 -- )
|
||||
|
|
@ -463,9 +479,11 @@ M: #return collect-label-info*
|
|||
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 )
|
||||
[
|
||||
|
|
@ -493,13 +511,15 @@ M: #return collect-label-info*
|
|||
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 =
|
||||
|
|
|
|||
|
|
@ -142,7 +142,7 @@ M: object xyz ;
|
|||
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
|
||||
|
||||
! We don't want to use = to compare literals
|
||||
: foo reverse ;
|
||||
: foo ( seq -- seq' ) reverse ;
|
||||
|
||||
\ foo [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -41,11 +41,11 @@ C: <interval-constraint> interval-constraint
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ inference.state accessors combinators ;
|
|||
IN: inference.dataflow
|
||||
|
||||
! Computed value
|
||||
: <computed> \ <computed> counter ;
|
||||
: <computed> ( -- value ) \ <computed> counter ;
|
||||
|
||||
! Literal value
|
||||
TUPLE: value < identity-tuple literal uid recursion ;
|
||||
|
|
@ -88,7 +88,7 @@ M: object flatten-curry , ;
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -217,9 +217,9 @@ M: #call-label calls-label* param>> eq? ;
|
|||
|
||||
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>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,21 +29,19 @@ M: too-many-r> summary
|
|||
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
|
||||
|
|
|
|||
|
|
@ -83,13 +83,13 @@ ARTICLE: "inference-errors" "Inference errors"
|
|||
"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."
|
||||
|
|
|
|||
|
|
@ -48,20 +48,12 @@ IN: inference.tests
|
|||
] 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 ;
|
||||
|
||||
|
|
@ -131,7 +123,7 @@ SYMBOL: sym-test
|
|||
|
||||
{ 0 1 } [ sym-test ] must-infer-as
|
||||
|
||||
: terminator-branch
|
||||
: terminator-branch ( a -- b )
|
||||
dup [
|
||||
length
|
||||
] [
|
||||
|
|
@ -198,11 +190,10 @@ DEFER: blah4
|
|||
[ [ [ 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
|
||||
|
||||
|
|
@ -224,7 +215,7 @@ DEFER: do-crap*
|
|||
{ 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 ;
|
||||
|
|
@ -448,7 +439,7 @@ DEFER: bar
|
|||
! 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
|
||||
|
||||
|
|
@ -472,9 +463,7 @@ M: string my-hook "a string" ;
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -557,26 +546,26 @@ ERROR: custom-error ;
|
|||
|
||||
[ [ 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
|
||||
|
|
|
|||
|
|
@ -29,6 +29,6 @@ M: callable dataflow-with
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -583,7 +583,7 @@ set-primitive-effect
|
|||
|
||||
\ (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
|
||||
|
||||
|
|
|
|||
|
|
@ -12,16 +12,16 @@ SYMBOL: d-in
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ USING: sequences inference.transforms tools.test math kernel
|
|||
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
|
||||
|
||||
|
|
@ -20,25 +20,12 @@ classes ;
|
|||
|
||||
[ 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
|
||||
|
||||
|
|
@ -46,13 +33,13 @@ C: <color> color
|
|||
|
||||
[ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ strings accessors io.encodings.utf8 math destructors ;
|
|||
|
||||
\ 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
|
||||
|
|
|
|||
|
|
@ -260,7 +260,8 @@ HOOK: delete-directory io-backend ( path -- )
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -26,7 +26,8 @@ M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
|
|||
: 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 [
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: math.bitfields.tests
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ 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
|
||||
|
|
@ -206,7 +206,7 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -177,7 +177,7 @@ IN: math.intervals.tests
|
|||
{ 3 [ (a,b] ] }
|
||||
} case ;
|
||||
|
||||
: random-op
|
||||
: random-op ( -- pair )
|
||||
{
|
||||
{ + interval+ }
|
||||
{ - interval- }
|
||||
|
|
@ -192,7 +192,7 @@ IN: math.intervals.tests
|
|||
] when
|
||||
random ;
|
||||
|
||||
: interval-test
|
||||
: interval-test ( -- ? )
|
||||
random-interval random-interval random-op ! 3dup . . .
|
||||
0 pick interval-contains? over first { / /i } member? and [
|
||||
3drop t
|
||||
|
|
@ -204,7 +204,7 @@ IN: math.intervals.tests
|
|||
|
||||
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
|
||||
|
||||
: random-comparison
|
||||
: random-comparison ( -- pair )
|
||||
{
|
||||
{ < interval< }
|
||||
{ <= interval<= }
|
||||
|
|
@ -212,7 +212,7 @@ IN: math.intervals.tests
|
|||
{ >= 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? [
|
||||
|
|
|
|||
|
|
@ -8,9 +8,9 @@ TUPLE: interval from to ;
|
|||
|
||||
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> ;
|
||||
|
|
@ -197,7 +197,8 @@ SYMBOL: incomparable
|
|||
[ 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 -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ DEFER: base>
|
|||
SYMBOL: radix
|
||||
SYMBOL: negative?
|
||||
|
||||
: sign negative? get "-" "+" ? ;
|
||||
: sign ( -- str ) negative? get "-" "+" ? ;
|
||||
|
||||
: with-radix ( radix quot -- )
|
||||
radix swap with-variable ; inline
|
||||
|
|
|
|||
|
|
@ -161,7 +161,8 @@ SYMBOL: potential-loops
|
|||
} 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
|
||||
|
|
@ -214,7 +215,7 @@ SYMBOL: potential-loops
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -188,7 +188,7 @@ $nl
|
|||
|
||||
ABOUT: "parser"
|
||||
|
||||
: $parsing-note
|
||||
: $parsing-note ( children -- )
|
||||
drop
|
||||
"This word should only be called from parsing words."
|
||||
$notes ;
|
||||
|
|
@ -431,9 +431,9 @@ HELP: lexer-factory
|
|||
{ $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
|
||||
|
|
|
|||
|
|
@ -221,6 +221,8 @@ ERROR: unexpected want got ;
|
|||
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 )
|
||||
|
|
@ -366,7 +368,7 @@ M: staging-violation summary
|
|||
{ [ 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 ;
|
||||
|
||||
|
|
@ -393,15 +395,15 @@ SYMBOL: lexer-factory
|
|||
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 ;
|
||||
|
|
@ -415,7 +417,7 @@ 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
|
||||
|
|
@ -429,11 +431,11 @@ 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 )
|
||||
|
|
|
|||
|
|
@ -5,11 +5,13 @@ hashtables io assocs kernel math namespaces sequences strings
|
|||
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* ;
|
||||
|
||||
|
|
@ -26,9 +28,11 @@ GENERIC: pprint* ( obj -- )
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -43,13 +47,16 @@ GENERIC: pprint* ( obj -- )
|
|||
<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 ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ prettyprint.config sorting splitting math.parser vocabs
|
|||
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 )
|
||||
[
|
||||
|
|
@ -145,46 +145,51 @@ GENERIC: see ( defspec -- )
|
|||
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* ;
|
||||
|
||||
|
|
@ -220,7 +225,7 @@ M: word declarations.
|
|||
POSTPONE: flushable
|
||||
} [ declaration. ] with each ;
|
||||
|
||||
: pprint-; \ ; pprint-word ;
|
||||
: pprint-; ( -- ) \ ; pprint-word ;
|
||||
|
||||
: (see) ( spec -- )
|
||||
<colon dup synopsis*
|
||||
|
|
|
|||
|
|
@ -190,9 +190,9 @@ M: block short-section ( block -- )
|
|||
: 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) ;
|
||||
|
||||
|
|
@ -288,7 +288,7 @@ M: colon unindent-first-line? drop t ;
|
|||
SYMBOL: prev
|
||||
SYMBOL: next
|
||||
|
||||
: split-groups [ t , ] when ;
|
||||
: split-groups ( ? -- ) [ t , ] when ;
|
||||
|
||||
M: f section-start-group? drop t ;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,36 +27,28 @@ C: <slot-spec> slot-spec
|
|||
>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? [
|
||||
|
|
|
|||
|
|
@ -413,7 +413,13 @@ HELP: (
|
|||
{ $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..." }
|
||||
|
|
|
|||
|
|
@ -182,10 +182,14 @@ IN: bootstrap.syntax
|
|||
] 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
|
||||
|
||||
"<<" [
|
||||
|
|
|
|||
|
|
@ -37,11 +37,11 @@ mailbox variables sleep-entry ;
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -50,18 +50,18 @@ H{ } clone root-cache set-global
|
|||
|
||||
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 [
|
||||
|
|
|
|||
|
|
@ -334,7 +334,7 @@ HELP: bootstrap-word
|
|||
{ $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." } ;
|
||||
|
|
|
|||
|
|
@ -201,8 +201,7 @@ ERROR: bad-create name vocab ;
|
|||
: 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 ;
|
||||
|
|
@ -225,6 +224,6 @@ M: word hashcode*
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ help.definitions io io.files kernel namespaces vocabs sequences
|
|||
parser vocabs.loader ;
|
||||
IN: bootstrap.help
|
||||
|
||||
: load-help
|
||||
: load-help ( -- )
|
||||
"alien.syntax" require
|
||||
"compiler" require
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
|
||||
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 ;
|
||||
|
|
@ -89,7 +90,7 @@ PRIVATE>
|
|||
: >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 ;
|
||||
|
|
@ -273,7 +274,7 @@ M: timestamp time-
|
|||
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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings alien.compiler
|
|||
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 )
|
||||
|
|
@ -196,7 +196,8 @@ H{
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -84,7 +84,8 @@ M: linked-error error.
|
|||
|
||||
C: <linked-error> linked-error
|
||||
|
||||
: ?linked dup linked-error? [ rethrow ] when ;
|
||||
: ?linked ( message -- message )
|
||||
dup linked-error? [ rethrow ] when ;
|
||||
|
||||
TUPLE: linked-thread < thread supervisor ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ GENERIC: send ( message thread -- )
|
|||
M: thread send ( message thread -- )
|
||||
check-registered mailbox-of mailbox-put ;
|
||||
|
||||
: my-mailbox self mailbox-of ;
|
||||
: my-mailbox ( -- mailbox ) self mailbox-of ;
|
||||
|
||||
: receive ( -- message )
|
||||
my-mailbox mailbox-get ?linked ;
|
||||
|
|
|
|||
|
|
@ -149,7 +149,8 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
|
|||
|
||||
SYMBOL: event-stream-callbacks
|
||||
|
||||
: event-stream-counter \ event-stream-counter counter ;
|
||||
: event-stream-counter ( -- n )
|
||||
\ event-stream-counter counter ;
|
||||
|
||||
[
|
||||
event-stream-callbacks global
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 ;
|
||||
|
|
@ -20,9 +20,9 @@ TUPLE: document locs ;
|
|||
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 ;
|
||||
|
|
@ -178,7 +178,7 @@ M: one-char-elt next-elt 2drop ;
|
|||
>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
|
||||
|
|
|
|||
|
|
@ -51,9 +51,7 @@ M: object find-parse-error
|
|||
[ 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 . ]
|
||||
[
|
||||
|
|
@ -63,3 +61,8 @@ M: object find-parse-error
|
|||
readln
|
||||
] bi
|
||||
] all? drop ;
|
||||
|
||||
: fix ( word -- )
|
||||
[ "Fixing " write pprint " and all usages..." print nl ]
|
||||
[ [ smart-usage ] keep prefix ] bi
|
||||
edit-each ;
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ quotations arrays namespaces qualified ;
|
|||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -46,12 +46,12 @@ M: predicate word-help* drop \ $predicate ;
|
|||
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
|
||||
|
|
@ -114,15 +114,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
: $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
|
||||
|
|
@ -135,12 +127,8 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
":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? [
|
||||
|
|
|
|||
|
|
@ -22,8 +22,8 @@ SYMBOL: span
|
|||
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
|
||||
|
|
@ -58,18 +58,23 @@ M: f print-element drop ;
|
|||
|
||||
! 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 -- )
|
||||
|
|
@ -230,7 +235,7 @@ M: word ($instance)
|
|||
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
|
||||
|
|
@ -278,18 +283,18 @@ M: string ($instance)
|
|||
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."
|
||||
|
|
|
|||
|
|
@ -67,13 +67,11 @@ SYMBOL: html
|
|||
|
||||
: <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 ;
|
||||
|
||||
|
|
@ -81,21 +79,21 @@ SYMBOL: html
|
|||
#! 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 ;
|
||||
|
||||
|
|
@ -103,14 +101,14 @@ SYMBOL: html
|
|||
#! 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
|
||||
|
|
@ -134,11 +132,9 @@ SYMBOL: html
|
|||
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
|
||||
[
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: 8-bit decode-char
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -22,8 +22,11 @@ HOOK: (pipe) io-backend ( -- pipe )
|
|||
|
||||
<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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
|
|||
|
||||
SYMBOL: port-override
|
||||
|
||||
: (port) port-override get swap or ;
|
||||
: (port) ( port -- port' ) port-override get swap or ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -62,7 +62,8 @@ USE: unix
|
|||
[ >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
|
||||
|
|
|
|||
|
|
@ -30,10 +30,10 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
: 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 )
|
||||
|
|
|
|||
|
|
@ -146,7 +146,7 @@ GENERIC: lambda-rewrite* ( obj -- )
|
|||
|
||||
GENERIC: local-rewrite* ( obj -- )
|
||||
|
||||
: lambda-rewrite
|
||||
: lambda-rewrite ( quot -- quot' )
|
||||
[ local-rewrite* ] [ ] make
|
||||
[ [ lambda-rewrite* ] each ] [ ] make ;
|
||||
|
||||
|
|
@ -273,7 +273,7 @@ M: wlet local-rewrite*
|
|||
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 ;
|
||||
|
||||
|
|
@ -282,9 +282,9 @@ M: wlet local-rewrite*
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,6 @@ M: macro reset-word
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
! 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: _
|
||||
|
|
@ -11,7 +11,7 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ IN: math.functions.tests
|
|||
gcd nip
|
||||
] unit-test
|
||||
|
||||
: verify-gcd
|
||||
: verify-gcd ( a b -- ? )
|
||||
2dup gcd
|
||||
>r rot * swap rem r> = ;
|
||||
|
||||
|
|
|
|||
|
|
@ -59,5 +59,5 @@ M: memoized reset-word
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ TUPLE: history back forward ;
|
|||
: <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 -- )
|
||||
|
|
|
|||
|
|
@ -8,9 +8,11 @@ math.parser opengl.gl opengl.glu combinators arrays sequences
|
|||
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
|
||||
|
||||
|
|
@ -73,7 +75,8 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
>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) ;
|
||||
|
|
@ -81,13 +84,17 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: 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 ;
|
||||
|
|
@ -161,9 +168,9 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
: <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 [
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ TUPLE: openssl-context < secure-context aliens ;
|
|||
|
||||
TUPLE: bio handle disposed ;
|
||||
|
||||
: <bio> f bio boa ;
|
||||
: <bio> ( handle -- bio ) f bio boa ;
|
||||
|
||||
M: bio dispose* handle>> BIO_free ssl-error ;
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: classes inference inference.dataflow io kernel
|
|||
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
|
||||
|
|
@ -33,11 +33,11 @@ M: comment pprint*
|
|||
|
||||
: 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 -- )
|
||||
|
|
@ -63,18 +63,19 @@ MATCH-VARS: ?a ?b ?c ;
|
|||
} 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 ;
|
||||
|
|
@ -83,38 +84,38 @@ M: #call-label 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 ;
|
||||
|
|
@ -145,7 +146,7 @@ SYMBOL: node-count
|
|||
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 ] }
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: qualified
|
|||
#! Syntax: QUALIFIED-WITH: vocab prefix
|
||||
scan scan define-qualified ; parsing
|
||||
|
||||
: expect=> scan "=>" assert= ;
|
||||
: expect=> ( -- ) scan "=>" assert= ;
|
||||
|
||||
: partial-vocab ( words name -- assoc )
|
||||
dupd [
|
||||
|
|
|
|||
|
|
@ -102,9 +102,9 @@ MACRO: firstn ( n -- )
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ,, 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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -40,16 +40,14 @@ IN: tools.deploy.backend
|
|||
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."
|
||||
|
|
|
|||
|
|
@ -22,9 +22,9 @@ SYMBOL: deploy-io
|
|||
{ 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
|
||||
|
||||
|
|
@ -38,11 +38,11 @@ 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?
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ system math generator.fixup io.encodings.ascii accessors
|
|||
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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -64,9 +64,9 @@ M: object add-breakpoint ;
|
|||
|
||||
: (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 -- )
|
||||
{
|
||||
|
|
@ -80,7 +80,7 @@ M: object add-breakpoint ;
|
|||
|
||||
\ (step-into-execute) t "step-into?" set-word-prop
|
||||
|
||||
: (step-into-continuation)
|
||||
: (step-into-continuation) ( -- )
|
||||
continuation callstack >>call break ;
|
||||
|
||||
! Messages sent to walker thread
|
||||
|
|
@ -260,4 +260,4 @@ SYMBOL: +stopped+
|
|||
! For convenience
|
||||
IN: syntax
|
||||
|
||||
: B break ;
|
||||
: B ( -- ) break ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: ui.clipboards
|
|||
|
||||
! Two text transfer buffers
|
||||
TUPLE: clipboard contents ;
|
||||
: <clipboard> "" clipboard boa ;
|
||||
: <clipboard> ( -- clipboard ) "" clipboard boa ;
|
||||
|
||||
GENERIC: paste-clipboard ( gadget clipboard -- )
|
||||
|
||||
|
|
@ -26,6 +26,6 @@ SYMBOL: selection
|
|||
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 ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue