Merge git://factorcode.org/git/factor
commit
5898f19c54
14
Makefile
14
Makefile
|
@ -63,8 +63,9 @@ default:
|
|||
@echo "macosx-ppc"
|
||||
@echo "solaris-x86-32"
|
||||
@echo "solaris-x86-64"
|
||||
@echo "windows-ce-arm"
|
||||
@echo "windows-nt-x86-32"
|
||||
@echo "wince-arm"
|
||||
@echo "winnt-x86-32"
|
||||
@echo "winnt-x86-64"
|
||||
@echo ""
|
||||
@echo "Additional modifiers:"
|
||||
@echo ""
|
||||
|
@ -122,10 +123,13 @@ solaris-x86-32:
|
|||
solaris-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
|
||||
|
||||
windows-nt-x86-32:
|
||||
winnt-x86-32:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
|
||||
windows-ce-arm:
|
||||
winnt-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
|
||||
|
||||
wince-arm:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
|
||||
|
||||
macosx.app: factor
|
||||
|
@ -151,7 +155,7 @@ clean:
|
|||
rm -f factor*.dll libfactor*.*
|
||||
|
||||
vm/resources.o:
|
||||
windres vm/factor.rs vm/resources.o
|
||||
$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
||||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
|
|
@ -14,7 +14,7 @@ prettyprint ;
|
|||
! Testing the various bignum accessor
|
||||
10 <byte-array> "dump" set
|
||||
|
||||
[ "dump" get alien-address ] unit-test-fails
|
||||
[ "dump" get alien-address ] must-fail
|
||||
|
||||
[ 123 ] [
|
||||
123 "dump" get 0 set-alien-signed-1
|
||||
|
@ -61,9 +61,9 @@ cell 8 = [
|
|||
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
|
||||
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
|
||||
|
||||
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
|
||||
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
|
||||
|
||||
[ 1 1 <displaced-alien> ] unit-test-fails
|
||||
[ 1 1 <displaced-alien> ] must-fail
|
||||
|
||||
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
|
||||
|
||||
|
|
|
@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE
|
|||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
|
|
@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable
|
|||
tools.test vectors layouts system math vectors.private ;
|
||||
IN: temporary
|
||||
|
||||
[ -2 { "a" "b" "c" } nth ] unit-test-fails
|
||||
[ 10 { "a" "b" "c" } nth ] unit-test-fails
|
||||
[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
|
||||
[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
|
||||
[ -2 { "a" "b" "c" } nth ] must-fail
|
||||
[ 10 { "a" "b" "c" } nth ] must-fail
|
||||
[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail
|
||||
[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail
|
||||
[ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
|
||||
[ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
|
||||
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
|
||||
|
@ -17,5 +17,5 @@ IN: temporary
|
|||
[ { "a" "b" "c" "d" "e" } ]
|
||||
[ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test
|
||||
|
||||
[ -1 f <array> ] unit-test-fails
|
||||
[ cell-bits cell log2 - 2^ f <array> ] unit-test-fails
|
||||
[ -1 f <array> ] must-fail
|
||||
[ cell-bits cell log2 - 2^ f <array> ] must-fail
|
||||
|
|
|
@ -51,4 +51,4 @@ IN: temporary
|
|||
|
||||
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
|
||||
|
||||
[ -10 ?{ } resize-bit-array ] unit-test-fails
|
||||
[ -10 ?{ } resize-bit-array ] must-fail
|
||||
|
|
|
@ -203,14 +203,8 @@ M: f '
|
|||
|
||||
! Words
|
||||
|
||||
DEFER: emit-word
|
||||
|
||||
: emit-generic ( generic -- )
|
||||
dup "default-method" word-prop method-word emit-word
|
||||
"methods" word-prop [ nip method-word emit-word ] assoc-each ;
|
||||
|
||||
: emit-word ( word -- )
|
||||
dup generic? [ dup emit-generic ] when
|
||||
dup subwords [ emit-word ] each
|
||||
[
|
||||
dup hashcode ' ,
|
||||
dup word-name ' ,
|
||||
|
|
|
@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "millis" "system" }
|
||||
{ "type" "kernel.private" }
|
||||
{ "tag" "kernel.private" }
|
||||
{ "cwd" "io.files" }
|
||||
{ "cd" "io.files" }
|
||||
{ "modify-code-heap" "compiler.units" }
|
||||
{ "dlopen" "alien" }
|
||||
{ "dlsym" "alien" }
|
||||
|
|
|
@ -1,31 +1,70 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init command-line namespaces words debugger io
|
||||
kernel.private math memory continuations kernel io.files
|
||||
io.backend system parser vocabs sequences prettyprint
|
||||
vocabs.loader combinators splitting source-files strings
|
||||
definitions assocs compiler.errors compiler.units
|
||||
math.parser ;
|
||||
math.parser generic ;
|
||||
IN: bootstrap.stage2
|
||||
|
||||
SYMBOL: bootstrap-time
|
||||
|
||||
: default-image-name ( -- string )
|
||||
vm file-name windows? [ "." split1 drop ] when
|
||||
".image" append ;
|
||||
|
||||
: do-crossref ( -- )
|
||||
"Cross-referencing..." print flush
|
||||
H{ } clone crossref set-global
|
||||
xref-words
|
||||
xref-generics
|
||||
xref-sources ;
|
||||
|
||||
: load-components ( -- )
|
||||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||
seq-diff
|
||||
[ "bootstrap." swap append require ] each ;
|
||||
|
||||
: compile-remaining ( -- )
|
||||
"Compiling remaining words..." print flush
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap subset length number>string write ;
|
||||
|
||||
: print-report ( time -- )
|
||||
1000 /i
|
||||
60 /mod swap
|
||||
"Bootstrap completed in " write number>string write
|
||||
" minutes and " write number>string write " seconds." print
|
||||
|
||||
[ compiled? ] count-words " compiled words" print
|
||||
[ symbol? ] count-words " symbol words" print
|
||||
[ ] count-words " words total" print
|
||||
|
||||
"Bootstrapping is complete." print
|
||||
"Now, you can run Factor:" print
|
||||
vm write " -i=" write "output-image" get print flush ;
|
||||
|
||||
! Wrap everything in a catch which starts a listener so
|
||||
! you can see what went wrong, instead of dealing with a
|
||||
! fep
|
||||
[
|
||||
vm file-name windows? [ "." split1 drop ] when
|
||||
".image" append "output-image" set-global
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
"math help compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
parse-command-line
|
||||
|
||||
"-no-crossref" cli-args member? [
|
||||
"Cross-referencing..." print flush
|
||||
H{ } clone crossref set-global
|
||||
xref-words
|
||||
xref-sources
|
||||
] unless
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
|
||||
! Set dll paths
|
||||
wince? [ "windows.ce" require ] when
|
||||
|
@ -39,19 +78,12 @@ IN: bootstrap.stage2
|
|||
] if
|
||||
|
||||
[
|
||||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||
seq-diff
|
||||
[ "bootstrap." swap append require ] each
|
||||
load-components
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
"Compiling remaining words..." print flush
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each
|
||||
compile-remaining
|
||||
] when
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
@ -73,19 +105,13 @@ IN: bootstrap.stage2
|
|||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap subset length number>string write ;
|
||||
|
||||
[ compiled? ] count-words " compiled words" print
|
||||
[ symbol? ] count-words " symbol words" print
|
||||
[ ] count-words " words total" print
|
||||
|
||||
"Bootstrapping is complete." print
|
||||
"Now, you can run Factor:" print
|
||||
vm write " -i=" write "output-image" get print flush
|
||||
millis r> - dup bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
] [
|
||||
print-error :c "listener" vocab-main execute
|
||||
print-error :c restarts.
|
||||
"listener" vocab-main execute
|
||||
1 exit
|
||||
] recover
|
||||
|
|
|
@ -5,4 +5,4 @@ USING: tools.test byte-arrays ;
|
|||
|
||||
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
|
||||
|
||||
[ -10 B{ } resize-byte-array ] unit-test-fails
|
||||
[ -10 B{ } resize-byte-array ] must-fail
|
||||
|
|
|
@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
[ f ] [ union-1 union-class? ] unit-test
|
||||
[ t ] [ union-1 predicate-class? ] unit-test
|
||||
[ "union-1" ] [ 8 generic-update-test ] unit-test
|
||||
[ -7 generic-update-test ] unit-test-fails
|
||||
[ -7 generic-update-test ] must-fail
|
||||
|
||||
! Test mixins
|
||||
MIXIN: sequence-mixin
|
||||
|
@ -169,10 +169,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
|||
UNION: forget-class-bug-1 integer ;
|
||||
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
|
||||
|
||||
FORGET: forget-class-bug-1
|
||||
FORGET: forget-class-bug-2
|
||||
[
|
||||
\ forget-class-bug-1 forget
|
||||
\ forget-class-bug-2 forget
|
||||
] with-compilation-unit
|
||||
|
||||
[ t ] [ integer dll class-or interned? ] unit-test
|
||||
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
|
||||
|
||||
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
|
||||
|
||||
DEFER: mixin-forget-test-g
|
||||
|
||||
|
@ -191,7 +195,7 @@ DEFER: mixin-forget-test-g
|
|||
] unit-test
|
||||
|
||||
[ { } ] [ { } mixin-forget-test-g ] unit-test
|
||||
[ H{ } mixin-forget-test-g ] unit-test-fails
|
||||
[ H{ } mixin-forget-test-g ] must-fail
|
||||
|
||||
[ ] [
|
||||
{
|
||||
|
@ -205,7 +209,7 @@ DEFER: mixin-forget-test-g
|
|||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ { } mixin-forget-test-g ] unit-test-fails
|
||||
[ { } mixin-forget-test-g ] must-fail
|
||||
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
|
||||
|
||||
! Method flattening interfered with mixin update
|
||||
|
|
|
@ -38,7 +38,7 @@ namespaces combinators words ;
|
|||
! Interpreted
|
||||
[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
|
||||
|
||||
[ "x" case-test-1 ] unit-test-fails
|
||||
[ "x" case-test-1 ] must-fail
|
||||
|
||||
: case-test-2
|
||||
{
|
||||
|
|
|
@ -26,7 +26,7 @@ IN: compiler
|
|||
>r dupd save-effect r>
|
||||
f pick compiler-error
|
||||
over compiled-unxref
|
||||
compiled-xref ;
|
||||
over crossref? [ compiled-xref ] [ 2drop ] if ;
|
||||
|
||||
: compile-succeeded ( word -- effect dependencies )
|
||||
[
|
||||
|
|
|
@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ;
|
|||
|
||||
FUNCTION: int ffi_test_2 int x int y ;
|
||||
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
|
||||
[ "hi" 3 ffi_test_2 ] unit-test-fails
|
||||
[ "hi" 3 ffi_test_2 ] must-fail
|
||||
|
||||
FUNCTION: int ffi_test_3 int x int y int z int t ;
|
||||
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
|
||||
|
@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ;
|
|||
|
||||
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
|
||||
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
|
||||
[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails
|
||||
[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails
|
||||
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
|
||||
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
|
||||
|
||||
C-STRUCT: foo
|
||||
{ "int" "x" }
|
||||
|
@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ;
|
|||
|
||||
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
|
||||
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
|
||||
[ 1 2 ffi_test_15 ] unit-test-fails
|
||||
[ 1 2 ffi_test_15 ] must-fail
|
||||
|
||||
C-STRUCT: bar
|
||||
{ "long" "x" }
|
||||
|
@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
|
||||
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
|
||||
|
||||
[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test
|
||||
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: indirect-test-1
|
||||
"int" { } "cdecl" alien-indirect ;
|
||||
|
@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
|
||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
||||
|
||||
[ -1 indirect-test-1 ] unit-test-fails
|
||||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2
|
||||
"int" { "int" "int" } "cdecl" alien-indirect data-gc ;
|
||||
|
@ -120,7 +120,7 @@ unit-test
|
|||
|
||||
FUNCTION: double ffi_test_6 float x float y ;
|
||||
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
|
||||
[ "a" "b" ffi_test_6 ] unit-test-fails
|
||||
[ "a" "b" ffi_test_6 ] must-fail
|
||||
|
||||
FUNCTION: double ffi_test_7 double x double y ;
|
||||
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
|
||||
|
@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ;
|
|||
[ 987655432 ]
|
||||
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
|
||||
|
||||
[ 1111 f 123456789 ffi_test_22 ] unit-test-fails
|
||||
[ 1111 f 123456789 ffi_test_22 ] must-fail
|
||||
|
||||
C-STRUCT: rect
|
||||
{ "float" "x" }
|
||||
|
@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
|
|||
|
||||
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
|
||||
|
||||
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails
|
||||
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
|
||||
|
||||
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
|
||||
|
||||
|
@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
|||
|
||||
[ ] [ callback-1 callback_test_1 ] unit-test
|
||||
|
||||
: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ;
|
||||
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
|
||||
[ ] [ callback-2 callback_test_1 ] unit-test
|
||||
|
||||
|
|
|
@ -422,11 +422,11 @@ cell 8 = [
|
|||
|
||||
[
|
||||
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[
|
||||
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[
|
||||
4 5
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
|
|||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations ;
|
||||
continuations growable ;
|
||||
IN: temporary
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
|
@ -136,7 +136,7 @@ TUPLE: pred-test ;
|
|||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] unit-test-fails
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
|
@ -247,7 +247,7 @@ M: slice foozul ;
|
|||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] unit-test-fails
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ;
|
|||
: construct-empty-bug construct-empty ;
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method method-word flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
|
|
|
@ -92,8 +92,6 @@ DEFER: x-4
|
|||
|
||||
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
|
||||
|
||||
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
|
||||
|
||||
DEFER: g-test-1
|
||||
|
||||
DEFER: g-test-3
|
||||
|
@ -237,7 +235,7 @@ DEFER: flushable-test-2
|
|||
: bx ax ;
|
||||
[ \ bx forget ] with-compilation-unit
|
||||
|
||||
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
|
||||
[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
|
||||
|
||||
DEFER: defer-redefine-test-2
|
||||
|
||||
|
@ -245,8 +243,45 @@ DEFER: defer-redefine-test-2
|
|||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
|
||||
|
||||
[ defer-redefine-test-2 ] unit-test-fails
|
||||
[ defer-redefine-test-2 ] must-fail
|
||||
|
||||
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
|
||||
|
||||
[ 2 1 ] [ defer-redefine-test-2 ] unit-test
|
||||
|
||||
! Cross-referencing issue
|
||||
: compiled-xref-a ;
|
||||
|
||||
: compiled-xref-c ; inline
|
||||
|
||||
GENERIC: compiled-xref-b ( a -- b )
|
||||
|
||||
TUPLE: c-1 ;
|
||||
|
||||
M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
|
||||
|
||||
TUPLE: c-2 ;
|
||||
|
||||
M: c-2 compiled-xref-b drop 3 ;
|
||||
|
||||
[ t ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ compiled-xref-a forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ compiled-xref-a compiled-crossref get key?
|
||||
] unit-test
|
||||
|
|
|
@ -57,8 +57,8 @@ IN: temporary
|
|||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-call ] unit-test-fails
|
||||
[ [ drop ] compile-call ] unit-test-fails
|
||||
[ [ dup ] compile-call ] must-fail
|
||||
[ [ drop ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
|
||||
|
|
|
@ -10,7 +10,7 @@ words splitting ;
|
|||
: foo 3 throw 7 ;
|
||||
: bar foo 4 ;
|
||||
: baz bar 5 ;
|
||||
[ 3 ] [ [ baz ] catch ] unit-test
|
||||
[ baz ] [ 3 = ] must-fail-with
|
||||
[ t ] [
|
||||
symbolic-stack-trace
|
||||
[ word? ] subset
|
||||
|
@ -22,11 +22,11 @@ words splitting ;
|
|||
: stack-trace-contains? symbolic-stack-trace memq? ;
|
||||
|
||||
[ t ] [
|
||||
[ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
|
||||
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
|
||||
] unit-test
|
||||
|
||||
[ t f ] [
|
||||
[ { "hi" } bleh ] catch drop
|
||||
[ { "hi" } bleh ] ignore-errors
|
||||
\ + stack-trace-contains?
|
||||
\ > stack-trace-contains?
|
||||
] unit-test
|
||||
|
@ -34,6 +34,6 @@ words splitting ;
|
|||
: quux [ t [ "hi" throw ] when ] times ;
|
||||
|
||||
[ t ] [
|
||||
[ 10 quux ] catch drop
|
||||
[ 10 quux ] ignore-errors
|
||||
\ (each-integer) stack-trace-contains?
|
||||
] unit-test
|
||||
|
|
|
@ -28,9 +28,7 @@ HELP: redefine-error
|
|||
|
||||
HELP: remember-definition
|
||||
{ $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } }
|
||||
{ $description "Saves the location of a definition and associates this definition with the current source file."
|
||||
$nl
|
||||
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
|
||||
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
|
||||
|
||||
HELP: old-definitions
|
||||
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ;
|
||||
|
@ -38,11 +36,6 @@ HELP: old-definitions
|
|||
HELP: new-definitions
|
||||
{ $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ;
|
||||
|
||||
HELP: forward-error
|
||||
{ $values { "word" word } }
|
||||
{ $description "Throws a " { $link forward-error } "." }
|
||||
{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ;
|
||||
|
||||
HELP: with-compilation-unit
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." }
|
||||
|
|
|
@ -26,11 +26,6 @@ TUPLE: redefine-error def ;
|
|||
over new-definitions get first key? [ dup redefine-error ] when
|
||||
new-definitions get second (remember-definition) ;
|
||||
|
||||
TUPLE: forward-error word ;
|
||||
|
||||
: forward-error ( word -- )
|
||||
\ forward-error construct-boa throw ;
|
||||
|
||||
: forward-reference? ( word -- ? )
|
||||
dup old-definitions get assoc-stack
|
||||
[ new-definitions get assoc-stack not ]
|
||||
|
|
|
@ -23,10 +23,9 @@ $nl
|
|||
"Two words raise an error in the innermost error handler for the current dynamic extent:"
|
||||
{ $subsection throw }
|
||||
{ $subsection rethrow }
|
||||
"A set of words establish an error handler:"
|
||||
"Two words for establishing an error handler:"
|
||||
{ $subsection cleanup }
|
||||
{ $subsection recover }
|
||||
{ $subsection catch }
|
||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||
{ $subsection "errors-restartable" }
|
||||
{ $subsection "errors-post-mortem" } ;
|
||||
|
@ -147,12 +146,7 @@ HELP: throw
|
|||
{ $values { "error" object } }
|
||||
{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
|
||||
|
||||
HELP: catch
|
||||
{ $values { "try" quotation } { "error/f" object } }
|
||||
{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." }
|
||||
{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ;
|
||||
|
||||
{ catch cleanup recover } related-words
|
||||
{ cleanup recover } related-words
|
||||
|
||||
HELP: cleanup
|
||||
{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
|
||||
|
@ -166,7 +160,7 @@ HELP: rethrow
|
|||
{ $values { "error" object } }
|
||||
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
|
||||
{ $notes
|
||||
"This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
|
||||
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
|
||||
}
|
||||
{ $examples
|
||||
"The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
|
||||
|
|
|
@ -25,13 +25,11 @@ IN: temporary
|
|||
[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
|
||||
[ t ] [ callcc-namespace-test ] unit-test
|
||||
|
||||
[ f ] [ [ ] catch ] unit-test
|
||||
|
||||
[ 5 ] [ [ 5 throw ] catch ] unit-test
|
||||
[ 5 throw ] [ 5 = ] must-fail-with
|
||||
|
||||
[ t ] [
|
||||
[ "Hello" throw ] catch drop
|
||||
global [ error get ] bind
|
||||
[ "Hello" throw ] ignore-errors
|
||||
error get-global
|
||||
"Hello" =
|
||||
] unit-test
|
||||
|
||||
|
@ -41,13 +39,13 @@ IN: temporary
|
|||
|
||||
"!!! The following error is part of the test" print
|
||||
|
||||
[ [ "2 car" ] eval ] catch print-error
|
||||
[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
|
||||
|
||||
[ f throw ] unit-test-fails
|
||||
[ f throw ] must-fail
|
||||
|
||||
! Weird PowerPC bug.
|
||||
[ ] [
|
||||
[ "4" throw ] catch drop
|
||||
[ "4" throw ] ignore-errors
|
||||
data-gc
|
||||
data-gc
|
||||
] unit-test
|
||||
|
@ -56,10 +54,10 @@ IN: temporary
|
|||
[ f ] [ { "A" "B" } kernel-error? ] unit-test
|
||||
|
||||
! ! See how well callstack overflow is handled
|
||||
! [ clear drop ] unit-test-fails
|
||||
! [ clear drop ] must-fail
|
||||
!
|
||||
! : callstack-overflow callstack-overflow f ;
|
||||
! [ callstack-overflow ] unit-test-fails
|
||||
! [ callstack-overflow ] must-fail
|
||||
|
||||
: don't-compile-me { } [ ] each ;
|
||||
|
||||
|
@ -84,24 +82,20 @@ SYMBOL: error-counter
|
|||
[ 1 ] [ always-counter get ] unit-test
|
||||
[ 0 ] [ error-counter get ] unit-test
|
||||
|
||||
[ "a" ] [
|
||||
[
|
||||
[ "a" throw ]
|
||||
[ always-counter inc ]
|
||||
[ error-counter inc ] cleanup
|
||||
] catch
|
||||
] unit-test
|
||||
[
|
||||
[ "a" throw ]
|
||||
[ always-counter inc ]
|
||||
[ error-counter inc ] cleanup
|
||||
] [ "a" = ] must-fail-with
|
||||
|
||||
[ 2 ] [ always-counter get ] unit-test
|
||||
[ 1 ] [ error-counter get ] unit-test
|
||||
|
||||
[ "a" ] [
|
||||
[
|
||||
[ ]
|
||||
[ always-counter inc "a" throw ]
|
||||
[ error-counter inc ] cleanup
|
||||
] catch
|
||||
] unit-test
|
||||
[
|
||||
[ ]
|
||||
[ always-counter inc "a" throw ]
|
||||
[ error-counter inc ] cleanup
|
||||
] [ "a" = ] must-fail-with
|
||||
|
||||
[ 3 ] [ always-counter get ] unit-test
|
||||
[ 1 ] [ error-counter get ] unit-test
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays vectors kernel kernel.private sequences
|
||||
namespaces math splitting sorting quotations assocs ;
|
||||
|
@ -17,9 +17,6 @@ SYMBOL: restarts
|
|||
|
||||
: c> ( -- continuation ) catchstack* pop ;
|
||||
|
||||
: (catch) ( quot -- newquot )
|
||||
[ swap >c call c> drop ] curry ; inline
|
||||
|
||||
: dummy ( -- obj )
|
||||
#! Optimizing compiler assumes stack won't be messed with
|
||||
#! in-transit. To ensure that a value is actually reified
|
||||
|
@ -120,11 +117,8 @@ PRIVATE>
|
|||
catchstack* empty? [ die ] when
|
||||
dup save-error c> continue-with ;
|
||||
|
||||
: catch ( try -- error/f )
|
||||
(catch) [ f ] compose callcc1 ; inline
|
||||
|
||||
: recover ( try recovery -- )
|
||||
>r (catch) r> ifcc ; inline
|
||||
>r [ swap >c call c> drop ] curry r> ifcc ; inline
|
||||
|
||||
: cleanup ( try cleanup-always cleanup-error -- )
|
||||
over >r compose [ dip rethrow ] curry
|
||||
|
|
|
@ -261,6 +261,10 @@ windows? [
|
|||
cell "ulonglong" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
macosx? [
|
||||
cell "double" c-type set-c-type-align
|
||||
] when
|
||||
|
||||
T{ x86-backend f 4 } compiler-backend set-global
|
||||
|
||||
: sse2? "Intrinsic" throw ;
|
||||
|
|
|
@ -87,7 +87,32 @@ TUPLE: assert got expect ;
|
|||
|
||||
: depth ( -- n ) datastack length ;
|
||||
|
||||
: assert-depth ( quot -- ) depth slip depth swap assert= ;
|
||||
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
|
||||
2dup [ length ] 2apply min tuck tail >r tail r> ;
|
||||
|
||||
TUPLE: relative-underflow stack ;
|
||||
|
||||
: relative-underflow ( before after -- * )
|
||||
trim-datastacks nip \ relative-underflow construct-boa throw ;
|
||||
|
||||
M: relative-underflow summary
|
||||
drop "Too many items removed from data stack" ;
|
||||
|
||||
TUPLE: relative-overflow stack ;
|
||||
|
||||
M: relative-overflow summary
|
||||
drop "Superfluous items pushed to data stack" ;
|
||||
|
||||
: relative-overflow ( before after -- * )
|
||||
trim-datastacks drop \ relative-overflow construct-boa throw ;
|
||||
|
||||
: assert-depth ( quot -- )
|
||||
>r datastack r> swap slip >r datastack r>
|
||||
2dup [ length ] compare sgn {
|
||||
{ -1 [ relative-underflow ] }
|
||||
{ 0 [ 2drop ] }
|
||||
{ 1 [ relative-overflow ] }
|
||||
} case ; inline
|
||||
|
||||
: expired-error. ( obj -- )
|
||||
"Object did not survive image save/load: " write third . ;
|
||||
|
@ -222,9 +247,6 @@ M: redefine-error error.
|
|||
"Re-definition of " write
|
||||
redefine-error-def . ;
|
||||
|
||||
M: forward-error error.
|
||||
"Forward reference to " write forward-error-word . ;
|
||||
|
||||
M: undefined summary
|
||||
drop "Calling a deferred word before it has been defined" ;
|
||||
|
||||
|
|
|
@ -52,9 +52,7 @@ $nl
|
|||
$nl
|
||||
"If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image."
|
||||
$nl
|
||||
"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used."
|
||||
{ $subsection forward-error }
|
||||
"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image."
|
||||
"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used."
|
||||
$nl
|
||||
"The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case."
|
||||
{ $subsection redefine-error } ;
|
||||
|
|
|
@ -6,6 +6,8 @@ TUPLE: combination-1 ;
|
|||
|
||||
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
|
||||
|
||||
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
|
||||
|
||||
SYMBOL: generic-1
|
||||
|
||||
[
|
||||
|
@ -20,7 +22,7 @@ SYMBOL: generic-1
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
GENERIC: some-generic
|
||||
GENERIC: some-generic ( a -- b )
|
||||
|
||||
USE: arrays
|
||||
|
||||
|
|
|
@ -144,6 +144,11 @@ PRIVATE>
|
|||
: dlist-delete ( obj dlist -- obj/f )
|
||||
>r [ eq? ] curry r> delete-node-if ;
|
||||
|
||||
: dlist-delete-all ( dlist -- )
|
||||
f over set-dlist-front
|
||||
f over set-dlist-back
|
||||
0 swap set-dlist-length ;
|
||||
|
||||
: dlist-each ( dlist quot -- )
|
||||
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces sequences strings words assocs
|
||||
combinators ;
|
||||
|
@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ;
|
|||
")" %
|
||||
] "" make ;
|
||||
|
||||
: stack-effect ( word -- effect/f )
|
||||
{
|
||||
{ [ dup symbol? ] [ drop 0 1 <effect> ] }
|
||||
{ [ dup "parent-generic" word-prop ] [
|
||||
"parent-generic" word-prop stack-effect
|
||||
] }
|
||||
{ [ t ] [
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip
|
||||
] }
|
||||
} cond ;
|
||||
GENERIC: stack-effect ( word -- effect/f )
|
||||
|
||||
M: symbol stack-effect drop 0 1 <effect> ;
|
||||
|
||||
M: word stack-effect
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip ;
|
||||
|
||||
M: effect clone
|
||||
[ effect-in clone ] keep effect-out clone <effect> ;
|
||||
|
|
|
@ -7,4 +7,4 @@ USING: float-arrays tools.test ;
|
|||
|
||||
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
|
||||
|
||||
[ -10 F{ } resize-float-array ] unit-test-fails
|
||||
[ -10 F{ } resize-float-array ] must-fail
|
||||
|
|
|
@ -3,8 +3,9 @@
|
|||
USING: arrays assocs classes combinators cpu.architecture
|
||||
effects generator.fixup generator.registers generic hashtables
|
||||
inference inference.backend inference.dataflow io kernel
|
||||
kernel.private layouts math namespaces optimizer prettyprint
|
||||
quotations sequences system threads words vectors ;
|
||||
kernel.private layouts math namespaces optimizer
|
||||
optimizer.specializers prettyprint quotations sequences system
|
||||
threads words vectors ;
|
||||
IN: generator
|
||||
|
||||
SYMBOL: compile-queue
|
||||
|
|
|
@ -107,10 +107,6 @@ HELP: make-generic
|
|||
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: init-methods
|
||||
{ $values { "word" word } }
|
||||
{ $description "Prepare to define a generic word." } ;
|
||||
|
||||
HELP: define-generic
|
||||
{ $values { "word" word } { "combination" "a method combination" } }
|
||||
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
|
||||
|
|
|
@ -16,7 +16,7 @@ M: word class-of drop "word" ;
|
|||
|
||||
[ "fixnum" ] [ 5 class-of ] unit-test
|
||||
[ "word" ] [ \ class-of class-of ] unit-test
|
||||
[ 3.4 class-of ] unit-test-fails
|
||||
[ 3.4 class-of ] must-fail
|
||||
|
||||
[ "Hello world" ] [ 4 foobar foobar ] unit-test
|
||||
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
|
||||
|
@ -90,7 +90,7 @@ M: number union-containment drop 2 ;
|
|||
"IN: temporary GENERIC: unhappy ( x -- x )" eval
|
||||
[
|
||||
"IN: temporary M: dictionary unhappy ;" eval
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
|
||||
GENERIC# complex-combination 1 ( a b -- c )
|
||||
|
@ -155,9 +155,7 @@ M: string my-hook "a string" ;
|
|||
|
||||
[ "an integer" ] [ 3 my-var set my-hook ] unit-test
|
||||
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
|
||||
[ T{ no-method f 1.0 my-hook } ] [
|
||||
1.0 my-var set [ my-hook ] catch
|
||||
] unit-test
|
||||
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
|
||||
|
||||
GENERIC: tag-and-f ( x -- x x )
|
||||
|
||||
|
@ -176,6 +174,9 @@ M: f tag-and-f 4 ;
|
|||
! define-class hashing issue
|
||||
TUPLE: debug-combination ;
|
||||
|
||||
M: debug-combination make-default-method
|
||||
2drop [ "Oops" throw ] ;
|
||||
|
||||
M: debug-combination perform-combination
|
||||
drop
|
||||
order [ dup class-hashes ] { } map>assoc sort-keys
|
||||
|
@ -200,3 +201,40 @@ TUPLE: redefinition-test-tuple ;
|
|||
redefinition-test-generic ,
|
||||
] { } make all-equal?
|
||||
] unit-test
|
||||
|
||||
! Issues with forget
|
||||
GENERIC: generic-forget-test-1
|
||||
|
||||
M: integer generic-forget-test-1 / ;
|
||||
|
||||
[ t ] [
|
||||
\ / usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-1/integer" = ] contains?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ \ generic-forget-test-1 forget ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ / usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-1/integer" = ] contains?
|
||||
] unit-test
|
||||
|
||||
GENERIC: generic-forget-test-2
|
||||
|
||||
M: sequence generic-forget-test-2 = ;
|
||||
|
||||
[ t ] [
|
||||
\ = usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ { sequence generic-forget-test-2 } forget ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ = usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
||||
] unit-test
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel sequences namespaces assocs hashtables
|
||||
definitions kernel.private classes classes.private
|
||||
quotations arrays vocabs ;
|
||||
quotations arrays vocabs effects ;
|
||||
IN: generic
|
||||
|
||||
! Method combination protocol
|
||||
|
@ -65,15 +65,21 @@ TUPLE: check-method class generic ;
|
|||
: make-method-def ( quot word combination -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method" word-prop method-generic stack-effect ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
[ method-word-name f <word> dup ] keep
|
||||
"parent-generic" set-word-prop
|
||||
dup rot define ;
|
||||
method-word-name f <word>
|
||||
dup rot define
|
||||
dup xref ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa ;
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "method" set-word-prop ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
|
@ -96,7 +102,9 @@ M: method-spec definition
|
|||
first2 method dup [ method-def ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method [ delete-at ] with-methods ;
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget* first2 forget-method ;
|
||||
|
||||
|
@ -120,13 +128,27 @@ M: class forget* ( class -- )
|
|||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "methods" word-prop
|
||||
H{ } assoc-like
|
||||
"methods" set-word-prop ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
2dup "combination" set-word-prop
|
||||
dupd define-default-method
|
||||
dup init-methods
|
||||
make-generic ;
|
||||
over "combination" word-prop over = [
|
||||
2drop
|
||||
] [
|
||||
2dup "combination" set-word-prop
|
||||
over H{ } clone "methods" set-word-prop
|
||||
dupd define-default-method
|
||||
make-generic
|
||||
] if ;
|
||||
|
||||
GENERIC: subwords ( word -- seq )
|
||||
|
||||
M: word subwords drop f ;
|
||||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add
|
||||
[ method-word ] map ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
|
||||
: xref-generics ( -- )
|
||||
all-words [ subwords [ xref ] each ] each ;
|
||||
|
|
|
@ -10,7 +10,7 @@ TUPLE: standard-combination # ;
|
|||
|
||||
M: standard-combination method-prologue
|
||||
standard-combination-# object
|
||||
<array> swap add [ declare ] curry ;
|
||||
<array> swap add* [ declare ] curry ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
|
@ -91,7 +91,7 @@ TUPLE: no-method object generic ;
|
|||
|
||||
: class-hash-dispatch-quot ( methods quot picker -- quot )
|
||||
>r >r hash-methods r> map
|
||||
hash-dispatch-quot r> [ class-hash ] rot 3append ;
|
||||
hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
|
||||
|
||||
: big-generic ( methods -- quot )
|
||||
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||
|
|
|
@ -9,16 +9,16 @@ IN: temporary
|
|||
|
||||
! overflow bugs
|
||||
[ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ]
|
||||
unit-test-fails
|
||||
must-fail
|
||||
|
||||
[ most-positive-fixnum 2 * 2 + { 1 } clone nth ]
|
||||
unit-test-fails
|
||||
must-fail
|
||||
|
||||
[ most-positive-fixnum 2 * 2 + V{ } clone lengthen ]
|
||||
unit-test-fails
|
||||
must-fail
|
||||
|
||||
[ most-positive-fixnum 2 * 2 + V{ } clone set-length ]
|
||||
unit-test-fails
|
||||
must-fail
|
||||
|
||||
[ ] [
|
||||
10 V{ } [ set-length ] keep
|
||||
|
|
|
@ -127,9 +127,9 @@ H{ } "x" set
|
|||
! Another crash discovered by erg
|
||||
[ ] [
|
||||
H{ } clone
|
||||
[ 1 swap set-at ] catch drop
|
||||
[ 2 swap set-at ] catch drop
|
||||
[ 3 swap set-at ] catch drop
|
||||
[ 1 swap set-at ] ignore-errors
|
||||
[ 2 swap set-at ] ignore-errors
|
||||
[ 3 swap set-at ] ignore-errors
|
||||
drop
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test
|
|||
heaps heaps.private ;
|
||||
IN: temporary
|
||||
|
||||
[ <min-heap> heap-pop ] unit-test-fails
|
||||
[ <max-heap> heap-pop ] unit-test-fails
|
||||
[ <min-heap> heap-pop ] must-fail
|
||||
[ <max-heap> heap-pop ] must-fail
|
||||
|
||||
[ t ] [ <min-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test
|
||||
|
|
|
@ -10,8 +10,8 @@ IN: inference.backend
|
|||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "parent-generic" word-prop
|
||||
[ inline? ] [ "inline" word-prop ] ?if ;
|
||||
dup "method" word-prop
|
||||
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
|
|
|
@ -12,14 +12,14 @@ IN: temporary
|
|||
{ 1 2 } [ dup ] unit-test-effect
|
||||
|
||||
{ 1 2 } [ [ dup ] call ] unit-test-effect
|
||||
[ [ call ] infer ] unit-test-fails
|
||||
[ [ call ] infer ] must-fail
|
||||
|
||||
{ 2 4 } [ 2dup ] unit-test-effect
|
||||
|
||||
{ 1 0 } [ [ ] [ ] if ] unit-test-effect
|
||||
[ [ if ] infer ] unit-test-fails
|
||||
[ [ [ ] if ] infer ] unit-test-fails
|
||||
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
|
||||
[ [ if ] infer ] must-fail
|
||||
[ [ [ ] if ] infer ] must-fail
|
||||
[ [ [ 2 ] [ ] if ] infer ] must-fail
|
||||
{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
|
||||
|
||||
{ 4 3 } [
|
||||
|
@ -42,7 +42,7 @@ IN: temporary
|
|||
|
||||
[
|
||||
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
! Test inference of termination of control flow
|
||||
: termination-test-1
|
||||
|
@ -54,10 +54,10 @@ IN: temporary
|
|||
|
||||
: infinite-loop infinite-loop ;
|
||||
|
||||
[ [ infinite-loop ] infer ] unit-test-fails
|
||||
[ [ infinite-loop ] infer ] must-fail
|
||||
|
||||
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
|
||||
[ [ no-base-case-1 ] infer ] unit-test-fails
|
||||
[ [ no-base-case-1 ] infer ] must-fail
|
||||
|
||||
: simple-recursion-1 ( obj -- obj )
|
||||
dup [ simple-recursion-1 ] [ ] if ;
|
||||
|
@ -72,7 +72,7 @@ IN: temporary
|
|||
: bad-recursion-2 ( obj -- obj )
|
||||
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-2 ] infer ] unit-test-fails
|
||||
[ [ bad-recursion-2 ] infer ] must-fail
|
||||
|
||||
: funny-recursion ( obj -- obj )
|
||||
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
||||
|
@ -192,7 +192,7 @@ DEFER: blah4
|
|||
[ swap slip ] keep swap bad-combinator
|
||||
] if ; inline
|
||||
|
||||
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
|
||||
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
|
||||
|
||||
! Regression
|
||||
: bad-input#
|
||||
|
@ -207,13 +207,13 @@ DEFER: blah4
|
|||
DEFER: do-crap
|
||||
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
|
||||
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
|
||||
[ [ do-crap ] infer ] unit-test-fails
|
||||
[ [ do-crap ] infer ] must-fail
|
||||
|
||||
! This one does not
|
||||
DEFER: do-crap*
|
||||
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
|
||||
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
|
||||
[ [ do-crap* ] infer ] unit-test-fails
|
||||
[ [ do-crap* ] infer ] must-fail
|
||||
|
||||
! Regression
|
||||
: too-deep ( a b -- c )
|
||||
|
@ -226,7 +226,7 @@ M: fixnum xyz 2array ;
|
|||
M: float xyz
|
||||
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
|
||||
|
||||
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
|
||||
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Doug Coleman discovered this one while working on the
|
||||
! calendar library
|
||||
|
@ -277,78 +277,66 @@ DEFER: #1
|
|||
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
||||
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
||||
|
||||
[ \ #4 word-def infer ] unit-test-fails
|
||||
[ [ #1 ] infer ] unit-test-fails
|
||||
[ \ #4 word-def infer ] must-fail
|
||||
[ [ #1 ] infer ] must-fail
|
||||
|
||||
! Similar
|
||||
DEFER: bar
|
||||
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
|
||||
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
|
||||
|
||||
[ [ foo ] infer ] unit-test-fails
|
||||
[ [ foo ] infer ] must-fail
|
||||
|
||||
[ 1234 infer ] unit-test-fails
|
||||
[ 1234 infer ] must-fail
|
||||
|
||||
! This used to hang
|
||||
[ t ] [
|
||||
[ [ [ dup call ] dup call ] infer ] catch
|
||||
inference-error?
|
||||
] unit-test
|
||||
[ [ [ dup call ] dup call ] infer ]
|
||||
[ inference-error? ] must-fail-with
|
||||
|
||||
: m dup call ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ [ m ] m ] infer ] catch inference-error?
|
||||
] unit-test
|
||||
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m' dup curry call ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ [ m' ] m' ] infer ] catch inference-error?
|
||||
] unit-test
|
||||
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m'' [ dup curry ] ; inline
|
||||
|
||||
: m''' m'' call call ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ [ m''' ] m''' ] infer ] catch inference-error?
|
||||
] unit-test
|
||||
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: m-if t over if ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ [ m-if ] m-if ] infer ] catch inference-error?
|
||||
] unit-test
|
||||
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! This doesn't hang but it's also an example of the
|
||||
! undedicable case
|
||||
[ t ] [
|
||||
[ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch
|
||||
inference-error?
|
||||
] unit-test
|
||||
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
|
||||
[ inference-error? ] must-fail-with
|
||||
|
||||
! This form should not have a stack effect
|
||||
|
||||
: bad-recursion-1 ( a -- b )
|
||||
dup [ drop bad-recursion-1 5 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-1 ] infer ] unit-test-fails
|
||||
[ [ bad-recursion-1 ] infer ] must-fail
|
||||
|
||||
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
|
||||
[ [ bad-bin ] infer ] unit-test-fails
|
||||
[ [ bad-bin ] infer ] must-fail
|
||||
|
||||
[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
|
||||
[ [ r> ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Regression
|
||||
[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
|
||||
[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Test some curry stuff
|
||||
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
|
||||
|
||||
{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
|
||||
|
||||
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
|
||||
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
|
||||
|
||||
! Test number protocol
|
||||
\ bitor must-infer
|
||||
|
@ -459,7 +447,7 @@ DEFER: bar
|
|||
: fooxxx ( a b -- c ) over [ foo ] when ; inline
|
||||
: barxxx fooxxx ;
|
||||
|
||||
[ [ barxxx ] infer ] unit-test-fails
|
||||
[ [ barxxx ] infer ] must-fail
|
||||
|
||||
! A typo
|
||||
{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inference.backend inference.state inference.dataflow
|
||||
inference.known-words inference.transforms inference.errors
|
||||
sequences prettyprint io effects kernel namespaces quotations
|
||||
words vocabs ;
|
||||
kernel io effects namespaces sequences quotations vocabs
|
||||
generic words ;
|
||||
IN: inference
|
||||
|
||||
GENERIC: infer ( quot -- effect )
|
||||
|
@ -28,4 +28,7 @@ M: callable dataflow-with
|
|||
] with-infer nip ;
|
||||
|
||||
: forget-errors ( -- )
|
||||
all-words [ f "no-effect" set-word-prop ] each ;
|
||||
all-words [
|
||||
dup subwords [ f "no-effect" set-word-prop ] each
|
||||
f "no-effect" set-word-prop
|
||||
] each ;
|
||||
|
|
|
@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ;
|
|||
: set-slots-test-2
|
||||
{ set-a-tuple-x set-a-tuple-x } set-slots ;
|
||||
|
||||
[ [ set-slots-test-2 ] infer ] unit-test-fails
|
||||
[ [ set-slots-test-2 ] infer ] must-fail
|
||||
|
|
|
@ -52,12 +52,12 @@ HELP: <file-appender>
|
|||
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: cwd ( -- path )
|
||||
HELP: cwd
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Outputs the current working directory of the Factor process." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
||||
HELP: cd ( path -- )
|
||||
HELP: cd
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Changes the current working directory of the Factor process." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
|
|
@ -2,7 +2,8 @@ IN: temporary
|
|||
USING: tools.test io.files io threads kernel continuations ;
|
||||
|
||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||
[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path <file-writer> [
|
||||
|
|
|
@ -1,10 +1,14 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.files
|
||||
USING: io.backend io.files.private io hashtables kernel math
|
||||
memory namespaces sequences strings assocs arrays definitions
|
||||
system combinators splitting sbufs ;
|
||||
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-writer> io-backend ( path -- stream )
|
||||
|
@ -25,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? )
|
|||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: trim-path-separators ( str -- newstr )
|
||||
: right-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] right-trim ;
|
||||
|
||||
: left-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] left-trim ;
|
||||
|
||||
: path+ ( str1 str2 -- str )
|
||||
>r trim-path-separators "/" r>
|
||||
[ path-separator? ] left-trim 3append ;
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
@ -57,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
|
|||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 2 [-] ] keep [ path-separator? ] find-last* ;
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
TUPLE: no-parent-directory path ;
|
||||
|
||||
|
@ -65,7 +72,7 @@ TUPLE: no-parent-directory path ;
|
|||
\ no-parent-directory construct-boa throw ;
|
||||
|
||||
: parent-directory ( path -- parent )
|
||||
trim-path-separators {
|
||||
right-trim-separators {
|
||||
{ [ dup empty? ] [ drop "/" ] }
|
||||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup [ path-separator? ] contains? not ] [ drop "." ] }
|
||||
|
@ -76,7 +83,11 @@ TUPLE: no-parent-directory path ;
|
|||
} cond ;
|
||||
|
||||
: file-name ( path -- string )
|
||||
dup last-path-separator [ 1+ tail ] [ drop ] if ;
|
||||
right-trim-separators {
|
||||
{ [ dup empty? ] [ drop "/" ] }
|
||||
{ [ dup last-path-separator ] [ 1+ tail ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
|
@ -86,7 +97,7 @@ TUPLE: no-parent-directory path ;
|
|||
"resource:" ?head [ resource-path ] when ;
|
||||
|
||||
: make-directories ( path -- )
|
||||
normalize-pathname trim-path-separators {
|
||||
normalize-pathname right-trim-separators {
|
||||
{ [ dup "." = ] [ ] }
|
||||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup empty? ] [ ] }
|
||||
|
|
|
@ -28,13 +28,13 @@ M: unclosable-stream dispose
|
|||
[ t ] [
|
||||
<unclosable-stream> <closing-stream> [
|
||||
<duplex-stream>
|
||||
[ dup dispose ] catch 2drop
|
||||
[ dup dispose ] [ 2drop ] recover
|
||||
] keep closing-stream-closed?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<closing-stream> [ <unclosable-stream>
|
||||
<duplex-stream>
|
||||
[ dup dispose ] catch 2drop
|
||||
[ dup dispose ] [ 2drop ] recover
|
||||
] keep closing-stream-closed?
|
||||
] unit-test
|
||||
|
|
|
@ -7,25 +7,22 @@ IN: temporary
|
|||
[ t ] [ [ \ = \ = ] all-equal? ] unit-test
|
||||
|
||||
! Don't leak extra roots if error is thrown
|
||||
[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test
|
||||
[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test
|
||||
|
||||
[ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test
|
||||
[ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
|
||||
|
||||
! Make sure we report the correct error on stack underflow
|
||||
[ { "kernel-error" 11 f f } ]
|
||||
[ [ clear drop ] catch ] unit-test
|
||||
[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ { "kernel-error" 13 f f } ]
|
||||
[ [ { } set-retainstack r> ] catch ] unit-test
|
||||
[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
: overflow-d 3 overflow-d ;
|
||||
|
||||
[ { "kernel-error" 12 f f } ]
|
||||
[ [ overflow-d ] catch ] unit-test
|
||||
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
|
@ -33,24 +30,17 @@ IN: temporary
|
|||
|
||||
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
|
||||
|
||||
[ { "kernel-error" 12 f f } ]
|
||||
[ [ overflow-d-alt ] catch ] unit-test
|
||||
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ [ :c ] string-out drop ] unit-test
|
||||
|
||||
: overflow-r 3 >r overflow-r ;
|
||||
|
||||
[ { "kernel-error" 14 f f } ]
|
||||
[ [ overflow-r ] catch ] unit-test
|
||||
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
! : overflow-c overflow-c 3 ;
|
||||
!
|
||||
! [ { "kernel-error" 16 f f } ]
|
||||
! [ [ overflow-c ] catch ] unit-test
|
||||
|
||||
[ -7 <byte-array> ] unit-test-fails
|
||||
[ -7 <byte-array> ] must-fail
|
||||
|
||||
[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
|
||||
[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
|
||||
|
@ -61,27 +51,27 @@ IN: temporary
|
|||
[ 4 ] [ 4 6 or ] unit-test
|
||||
[ 6 ] [ f 6 or ] unit-test
|
||||
|
||||
[ slip ] unit-test-fails
|
||||
[ slip ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 slip ] unit-test-fails
|
||||
[ 1 slip ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 2 slip ] unit-test-fails
|
||||
[ 1 2 slip ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
[ 1 2 3 slip ] unit-test-fails
|
||||
[ 1 2 3 slip ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
|
||||
[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
|
||||
|
||||
[ [ ] keep ] unit-test-fails
|
||||
[ [ ] keep ] must-fail
|
||||
|
||||
[ 6 ] [ 2 [ sq ] keep + ] unit-test
|
||||
|
||||
[ [ ] 2keep ] unit-test-fails
|
||||
[ 1 [ ] 2keep ] unit-test-fails
|
||||
[ [ ] 2keep ] must-fail
|
||||
[ 1 [ ] 2keep ] must-fail
|
||||
[ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
|
||||
|
||||
[ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
|
||||
|
@ -100,13 +90,13 @@ IN: temporary
|
|||
|
||||
[ ] [ callstack set-callstack ] unit-test
|
||||
|
||||
[ 3drop datastack ] unit-test-fails
|
||||
[ 3drop datastack ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
! Doesn't compile; important
|
||||
: foo 5 + 0 [ ] each ;
|
||||
|
||||
[ drop foo ] unit-test-fails
|
||||
[ drop foo ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
! Regression
|
||||
|
@ -117,4 +107,4 @@ IN: temporary
|
|||
: loop ( obj obj -- )
|
||||
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
||||
|
||||
[ loop ] unit-test-fails
|
||||
[ loop ] must-fail
|
||||
|
|
|
@ -22,7 +22,7 @@ IN: temporary
|
|||
[
|
||||
"\\ + 1 2 3 4" parse-interactive
|
||||
"cont" get continue-with
|
||||
] catch
|
||||
] ignore-errors
|
||||
"USE: debugger :1" eval
|
||||
] callcc1
|
||||
] unit-test
|
||||
|
@ -36,7 +36,7 @@ IN: temporary
|
|||
|
||||
[
|
||||
"USE: vocabs.loader.test.c" parse-interactive
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
[
|
||||
|
|
|
@ -121,8 +121,8 @@ unit-test
|
|||
|
||||
! We don't care if this fails or returns 0 (its CPU-specific)
|
||||
! as long as it doesn't crash
|
||||
[ ] [ [ 0 0 /i ] catch clear ] unit-test
|
||||
[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test
|
||||
[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test
|
||||
[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test
|
||||
|
||||
[ -2 ] [ 1 bitnot ] unit-test
|
||||
[ -2 ] [ 1 >bignum bitnot ] unit-test
|
||||
|
|
|
@ -105,6 +105,6 @@ unit-test
|
|||
! [ dup number>string string>number = ] all?
|
||||
! ] unit-test
|
||||
|
||||
[ 1 1 >base ] unit-test-fails
|
||||
[ 1 0 >base ] unit-test-fails
|
||||
[ 1 -1 >base ] unit-test-fails
|
||||
[ 1 1 >base ] must-fail
|
||||
[ 1 0 >base ] must-fail
|
||||
[ 1 -1 >base ] must-fail
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: temporary
|
|||
|
||||
TUPLE: testing x y z ;
|
||||
|
||||
[ save-image-and-exit ] unit-test-fails
|
||||
[ save-image-and-exit ] must-fail
|
||||
|
||||
[ ] [
|
||||
num-types get [
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class
|
|||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.pattern-match generic.standard ;
|
||||
optimizer.pattern-match generic.standard optimizer.specializers ;
|
||||
IN: optimizer.backend
|
||||
|
||||
SYMBOL: class-substitutions
|
||||
|
@ -245,18 +245,32 @@ M: #dispatch optimize-node*
|
|||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
dup get over inline? not or
|
||||
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
dup quotation? over array? or
|
||||
[ flat-length ] [ drop 1 ] if
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
tuck dispatching-class dup [
|
||||
swap [ 2array ] 2keep
|
||||
method method-word
|
||||
dup word-def flat-length 5 >=
|
||||
dup flat-length 10 >=
|
||||
[ 1quotation ] [ word-def ] if
|
||||
] [
|
||||
2drop t t
|
||||
|
@ -363,7 +377,7 @@ M: #dispatch optimize-node*
|
|||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> length tail*
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
|
|
|
@ -124,19 +124,19 @@ float-arrays combinators.private combinators ;
|
|||
] each
|
||||
|
||||
\ push-all
|
||||
{ { string array } { sbuf vector } }
|
||||
{ { string sbuf } { array vector } }
|
||||
"specializer" set-word-prop
|
||||
|
||||
\ append
|
||||
{ { string array } { string array } }
|
||||
{ { string string } { array array } }
|
||||
"specializer" set-word-prop
|
||||
|
||||
\ subseq
|
||||
{ fixnum fixnum { string array } }
|
||||
{ { fixnum fixnum string } { fixnum fixnum array } }
|
||||
"specializer" set-word-prop
|
||||
|
||||
\ reverse-here
|
||||
{ { string array } }
|
||||
{ { string } { array } }
|
||||
"specializer" set-word-prop
|
||||
|
||||
\ mismatch
|
||||
|
@ -147,9 +147,9 @@ float-arrays combinators.private combinators ;
|
|||
|
||||
\ >string { sbuf } "specializer" set-word-prop
|
||||
|
||||
\ >array { { string vector } } "specializer" set-word-prop
|
||||
\ >array { { string } { vector } } "specializer" set-word-prop
|
||||
|
||||
\ >vector { { array vector } } "specializer" set-word-prop
|
||||
\ >vector { { array } { vector } } "specializer" set-word-prop
|
||||
|
||||
\ >sbuf { string } "specializer" set-word-prop
|
||||
|
||||
|
@ -163,6 +163,6 @@ float-arrays combinators.private combinators ;
|
|||
|
||||
\ assoc-stack { vector } "specializer" set-word-prop
|
||||
|
||||
\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
|
||||
|
||||
\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
|
||||
|
|
|
@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math
|
|||
sequences ;
|
||||
IN: optimizer
|
||||
|
||||
ARTICLE: "specializers" "Word specializers"
|
||||
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
|
||||
$nl
|
||||
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:"
|
||||
{ $table
|
||||
{ { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } }
|
||||
{ { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } }
|
||||
{ { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } }
|
||||
{ { $snippet "*" } { "indicates no specialization should be performed on this parameter." } }
|
||||
}
|
||||
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
|
||||
$nl
|
||||
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
|
||||
$nl
|
||||
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
|
||||
$nl
|
||||
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
|
||||
{ $code
|
||||
"\\ append"
|
||||
"{ { string array } { string array } }"
|
||||
"\"specializer\" set-word-prop"
|
||||
}
|
||||
"The specialized version of a word which will be compiled by the compiler can be inspected:"
|
||||
{ $subsection specialized-def } ;
|
||||
|
||||
ARTICLE: "optimizer" "Optimizer"
|
||||
"The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them."
|
||||
$nl
|
||||
|
@ -43,7 +18,3 @@ HELP: optimize-1
|
|||
HELP: optimize
|
||||
{ $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } }
|
||||
{ $description "Continues to optimize a dataflow graph until a fixed point is reached." } ;
|
||||
|
||||
HELP: specialized-def
|
||||
{ $values { "word" word } { "quot" quotation } }
|
||||
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
|
||||
|
|
|
@ -1,10 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables kernel kernel.private math
|
||||
namespaces sequences vectors words strings layouts combinators
|
||||
combinators.private classes optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math inference.class
|
||||
generic.standard ;
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
@ -22,39 +19,3 @@ IN: optimizer
|
|||
|
||||
: optimize ( node -- newnode )
|
||||
optimize-1 [ optimize ] when ;
|
||||
|
||||
: simple-specializer ( quot dispatch# classes -- quot )
|
||||
swap (dispatch#) [
|
||||
object add* swap [ 2array ] curry map
|
||||
object method-alist>quot
|
||||
] with-variable ;
|
||||
|
||||
: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot )
|
||||
rot (dispatch#) [
|
||||
[
|
||||
picker %
|
||||
,
|
||||
get swap <array> ,
|
||||
\ dispatch ,
|
||||
] [ ] make
|
||||
] with-variable ;
|
||||
|
||||
: tag-specializer ( quot dispatch# -- quot )
|
||||
num-tags \ tag dispatch-specializer ;
|
||||
|
||||
: type-specializer ( quot dispatch# -- quot )
|
||||
num-types \ type dispatch-specializer ;
|
||||
|
||||
: make-specializer ( quot dispatch# spec -- quot )
|
||||
{
|
||||
{ [ dup number eq? ] [ drop tag-specializer ] }
|
||||
{ [ dup object eq? ] [ drop type-specializer ] }
|
||||
{ [ dup \ * eq? ] [ 2drop ] }
|
||||
{ [ dup array? ] [ simple-specializer ] }
|
||||
{ [ t ] [ 1array simple-specializer ] }
|
||||
} cond ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup word-def swap "specializer" word-prop [
|
||||
[ length ] keep <reversed> [ make-specializer ] 2each
|
||||
] when* ;
|
||||
|
|
|
@ -0,0 +1,26 @@
|
|||
IN: optimizer.specializers
|
||||
USING: help.markup help.syntax sequences words quotations ;
|
||||
|
||||
ARTICLE: "specializers" "Word specializers"
|
||||
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
|
||||
$nl
|
||||
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
|
||||
$nl
|
||||
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
|
||||
$nl
|
||||
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
|
||||
$nl
|
||||
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
|
||||
$nl
|
||||
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
|
||||
{ $code
|
||||
"\\ append"
|
||||
"{ { string string } { array array } }"
|
||||
"\"specializer\" set-word-prop"
|
||||
}
|
||||
"The specialized version of a word which will be compiled by the compiler can be inspected:"
|
||||
{ $subsection specialized-def } ;
|
||||
|
||||
HELP: specialized-def
|
||||
{ $values { "word" word } { "quot" quotation } }
|
||||
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables kernel kernel.private math
|
||||
namespaces sequences vectors words strings layouts combinators
|
||||
combinators.private classes generic.standard assocs ;
|
||||
IN: optimizer.specializers
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
||||
: make-specializer ( classes -- quot )
|
||||
dup length <reversed>
|
||||
[ (picker) 2array ] 2map
|
||||
[ drop object eq? not ] assoc-subset
|
||||
dup empty? [ drop [ t ] ] [
|
||||
[ (make-specializer) ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
|
||||
: tag-specializer ( quot -- newquot )
|
||||
[
|
||||
[ dup tag ] %
|
||||
num-tags get swap <array> ,
|
||||
\ dispatch ,
|
||||
] [ ] make ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup word-def swap "specializer" word-prop [
|
||||
dup { number } = [
|
||||
drop tag-specializer
|
||||
] [
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
[ declare ] curry pick append
|
||||
] { } map>assoc
|
||||
alist>quot
|
||||
] if
|
||||
] when* ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
|
@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer"
|
|||
{ $subsection <lexer> }
|
||||
"A word to test of the end of input has been reached:"
|
||||
{ $subsection still-parsing? }
|
||||
"A word to get the text of the current line:"
|
||||
{ $subsection line-text }
|
||||
"A word to advance the lexer to the next line:"
|
||||
{ $subsection next-line }
|
||||
"Two generic words to override the lexer's token boundary detection:"
|
||||
|
@ -202,9 +200,7 @@ HELP: location
|
|||
|
||||
HELP: save-location
|
||||
{ $values { "definition" "a definition specifier" } }
|
||||
{ $description "Saves the location of a definition and associates this definition with the current source file."
|
||||
$nl
|
||||
"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ;
|
||||
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
|
||||
|
||||
HELP: parser-notes
|
||||
{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ;
|
||||
|
@ -224,10 +220,6 @@ HELP: <parse-error>
|
|||
{ $values { "msg" "an error" } { "error" parse-error } }
|
||||
{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ;
|
||||
|
||||
HELP: line-text
|
||||
{ $values { "lexer" lexer } { "str" string } }
|
||||
{ $description "Outputs the text of the line being parsed." } ;
|
||||
|
||||
HELP: skip
|
||||
{ $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } }
|
||||
{ $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ;
|
||||
|
|
|
@ -93,12 +93,12 @@ IN: temporary
|
|||
! Funny bug
|
||||
[ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test
|
||||
|
||||
[ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails
|
||||
[ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail
|
||||
|
||||
! These should throw errors
|
||||
[ "HEX: zzz" eval ] unit-test-fails
|
||||
[ "OCT: 999" eval ] unit-test-fails
|
||||
[ "BIN: --0" eval ] unit-test-fails
|
||||
[ "HEX: zzz" eval ] must-fail
|
||||
[ "OCT: 999" eval ] must-fail
|
||||
[ "BIN: --0" eval ] must-fail
|
||||
|
||||
! Another funny bug
|
||||
[ t ] [
|
||||
|
@ -205,12 +205,10 @@ IN: temporary
|
|||
|
||||
"a" source-files get delete-at
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary : x ; : y 3 throw ; this is an error"
|
||||
<string-reader> "a" parse-stream
|
||||
] catch parse-error?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary : x ; : y 3 throw ; this is an error"
|
||||
<string-reader> "a" parse-stream
|
||||
] [ parse-error? ] must-fail-with
|
||||
|
||||
[ t ] [
|
||||
"y" "temporary" lookup >boolean
|
||||
|
@ -307,62 +305,58 @@ IN: temporary
|
|||
"killer?" "temporary" lookup >boolean
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?"
|
||||
<string-reader> "removing-the-predicate" parse-stream
|
||||
] catch [ redefine-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?"
|
||||
<string-reader> "removing-the-predicate" parse-stream
|
||||
] [ [ redefine-error? ] is? ] must-fail-with
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-1" parse-stream
|
||||
] catch [ redefine-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-1" parse-stream
|
||||
] [ [ redefine-error? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
|
||||
<string-reader> "redefining-a-class-2" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] catch [ redefine-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ [ redefine-error? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: temporary TUPLE: class-fwd-test ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] catch [ forward-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ [ no-word? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] catch [ forward-error? ] is?
|
||||
[
|
||||
"IN: temporary \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ [ no-word? ] is? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: temporary : foo ; TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||
] [ [ redefine-error? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary : foo ; TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||
] catch [ redefine-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
|
||||
] must-fail
|
||||
] with-file-vocabs
|
||||
|
||||
[
|
||||
|
|
|
@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs
|
|||
source-files classes hashtables compiler.errors compiler.units ;
|
||||
IN: parser
|
||||
|
||||
TUPLE: lexer text line column ;
|
||||
TUPLE: lexer text line line-text line-length column ;
|
||||
|
||||
: <lexer> ( text -- lexer ) 1 0 lexer construct-boa ;
|
||||
: next-line ( lexer -- )
|
||||
0 over set-lexer-column
|
||||
dup lexer-line over lexer-text ?nth over set-lexer-line-text
|
||||
dup lexer-line-text length over set-lexer-line-length
|
||||
dup lexer-line 1+ swap set-lexer-line ;
|
||||
|
||||
: line-text ( lexer -- str )
|
||||
dup lexer-line 1- swap lexer-text ?nth ;
|
||||
: <lexer> ( text -- lexer )
|
||||
0 { set-lexer-text set-lexer-line } lexer construct
|
||||
dup lexer-text empty? [ dup next-line ] unless ;
|
||||
|
||||
: location ( -- loc )
|
||||
file get lexer get lexer-line 2dup and
|
||||
|
@ -50,18 +55,14 @@ t parser-notes set-global
|
|||
"Note: " write dup print
|
||||
] when drop ;
|
||||
|
||||
: next-line ( lexer -- )
|
||||
0 over set-lexer-column
|
||||
dup lexer-line 1+ swap set-lexer-line ;
|
||||
|
||||
: skip ( i seq ? -- n )
|
||||
over >r
|
||||
[ swap CHAR: \s eq? xor ] curry find* drop
|
||||
[ r> drop ] [ r> length ] if* ; inline
|
||||
[ r> drop ] [ r> length ] if* ;
|
||||
|
||||
: change-column ( lexer quot -- )
|
||||
swap
|
||||
[ dup lexer-column swap line-text rot call ] keep
|
||||
[ dup lexer-column swap lexer-line-text rot call ] keep
|
||||
set-lexer-column ; inline
|
||||
|
||||
GENERIC: skip-blank ( lexer -- )
|
||||
|
@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- )
|
|||
|
||||
M: lexer skip-word ( lexer -- )
|
||||
[
|
||||
2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if
|
||||
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
|
||||
] change-column ;
|
||||
|
||||
: still-parsing? ( lexer -- ? )
|
||||
dup lexer-line swap lexer-text length <= ;
|
||||
|
||||
: still-parsing-line? ( lexer -- ? )
|
||||
dup lexer-column swap line-text length < ;
|
||||
dup lexer-column swap lexer-line-length < ;
|
||||
|
||||
: (parse-token) ( lexer -- str )
|
||||
[ lexer-column ] keep
|
||||
[ skip-word ] keep
|
||||
[ lexer-column ] keep
|
||||
line-text subseq ;
|
||||
lexer-line-text subseq ;
|
||||
|
||||
: parse-token ( lexer -- str/f )
|
||||
dup still-parsing? [
|
||||
|
@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ;
|
|||
|
||||
: <parse-error> ( msg -- error )
|
||||
file get
|
||||
lexer get lexer-line
|
||||
lexer get lexer-column
|
||||
lexer get line-text
|
||||
lexer get
|
||||
{ lexer-line lexer-column lexer-line-text } get-slots
|
||||
parse-error construct-boa
|
||||
[ set-delegate ] keep ;
|
||||
|
||||
|
@ -235,25 +235,29 @@ M: no-word summary
|
|||
|
||||
: no-word ( name -- newword )
|
||||
dup \ no-word construct-boa
|
||||
swap words-named word-restarts throw-restarts
|
||||
swap words-named [ forward-reference? not ] subset
|
||||
word-restarts throw-restarts
|
||||
dup word-vocabulary (use+) ;
|
||||
|
||||
: check-forward ( str word -- word )
|
||||
: check-forward ( str word -- word/f )
|
||||
dup forward-reference? [
|
||||
drop
|
||||
dup use get
|
||||
use get
|
||||
[ at ] with map [ ] subset
|
||||
[ forward-reference? not ] find nip
|
||||
[ ] [ forward-error ] ?if
|
||||
] [
|
||||
nip
|
||||
] if ;
|
||||
|
||||
: search ( str -- word )
|
||||
dup use get assoc-stack [ check-forward ] [ no-word ] if* ;
|
||||
: search ( str -- word/f )
|
||||
dup use get assoc-stack check-forward ;
|
||||
|
||||
: scan-word ( -- word/number/f )
|
||||
scan dup [ dup string>number [ ] [ search ] ?if ] when ;
|
||||
scan dup [
|
||||
dup search [ ] [
|
||||
dup string>number [ ] [ no-word ] ?if
|
||||
] ?if
|
||||
] when ;
|
||||
|
||||
TUPLE: staging-violation word ;
|
||||
|
||||
|
@ -303,10 +307,14 @@ SYMBOL: lexer-factory
|
|||
|
||||
! Parsing word utilities
|
||||
: parse-effect ( -- effect )
|
||||
")" parse-tokens { "--" } split1 dup [
|
||||
<effect>
|
||||
")" parse-tokens "(" over member? [
|
||||
"Stack effect declaration must not contain (" throw
|
||||
] [
|
||||
"Stack effect declaration must contain --" throw
|
||||
{ "--" } split1 dup [
|
||||
<effect>
|
||||
] [
|
||||
"Stack effect declaration must contain --" throw
|
||||
] if
|
||||
] if ;
|
||||
|
||||
TUPLE: bad-number ;
|
||||
|
@ -415,11 +423,6 @@ SYMBOL: interactive-vocabs
|
|||
over stack.
|
||||
] when 2drop ;
|
||||
|
||||
: outside-usages ( seq -- usages )
|
||||
dup [
|
||||
over usage [ pathname? not ] subset seq-diff
|
||||
] curry { } map>assoc ;
|
||||
|
||||
: filter-moved ( assoc -- newassoc )
|
||||
[
|
||||
drop where dup [ first ] when
|
||||
|
|
|
@ -15,4 +15,4 @@ IN: temporary
|
|||
|
||||
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
|
||||
|
||||
[ 1 \ + curry ] unit-test-fails
|
||||
[ 1 \ + curry ] must-fail
|
||||
|
|
|
@ -83,8 +83,8 @@ unit-test
|
|||
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
|
||||
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test
|
||||
|
||||
[ "a" -1 append ] unit-test-fails
|
||||
[ -1 "a" append ] unit-test-fails
|
||||
[ "a" -1 append ] must-fail
|
||||
[ -1 "a" append ] must-fail
|
||||
|
||||
[ [ ] ] [ 1 [ ] remove ] unit-test
|
||||
[ [ ] ] [ 1 [ 1 ] remove ] unit-test
|
||||
|
@ -119,7 +119,7 @@ unit-test
|
|||
|
||||
[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
|
||||
|
||||
[ 6 >vector 2 8 pick delete-slice ] unit-test-fails
|
||||
[ 6 >vector 2 8 pick delete-slice ] must-fail
|
||||
|
||||
[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
|
||||
|
||||
|
@ -173,7 +173,7 @@ unit-test
|
|||
|
||||
[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
|
||||
|
||||
[ -1 1 "abc" <slice> ] unit-test-fails
|
||||
[ -1 1 "abc" <slice> ] must-fail
|
||||
|
||||
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
|
||||
|
||||
|
@ -195,8 +195,8 @@ unit-test
|
|||
! Pathological case
|
||||
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
|
||||
|
||||
[ -10 "hi" "bye" copy ] unit-test-fails
|
||||
[ 10 "hi" "bye" copy ] unit-test-fails
|
||||
[ -10 "hi" "bye" copy ] must-fail
|
||||
[ 10 "hi" "bye" copy ] must-fail
|
||||
|
||||
[ V{ 1 2 3 5 6 } ] [
|
||||
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
|
||||
|
@ -228,13 +228,13 @@ unit-test
|
|||
[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
|
||||
|
||||
[ 0 ] [ f length ] unit-test
|
||||
[ f first ] unit-test-fails
|
||||
[ f first ] must-fail
|
||||
[ 3 ] [ 3 10 nth ] unit-test
|
||||
[ 3 ] [ 3 10 nth-unsafe ] unit-test
|
||||
[ -3 10 nth ] unit-test-fails
|
||||
[ 11 10 nth ] unit-test-fails
|
||||
[ -3 10 nth ] must-fail
|
||||
[ 11 10 nth ] must-fail
|
||||
|
||||
[ -1./0. 0 delete-nth ] unit-test-fails
|
||||
[ -1./0. 0 delete-nth ] must-fail
|
||||
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
|
||||
[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
|
||||
[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test
|
||||
|
|
|
@ -38,7 +38,7 @@ uses definitions ;
|
|||
|
||||
: (xref-source) ( source-file -- pathname uses )
|
||||
dup source-file-path <pathname> swap source-file-uses
|
||||
[ interned? ] subset ;
|
||||
[ crossref? ] subset ;
|
||||
|
||||
: xref-source ( source-file -- )
|
||||
(xref-source) crossref get add-vertex ;
|
||||
|
@ -96,3 +96,17 @@ SYMBOL: file
|
|||
source-file-definitions old-definitions set
|
||||
[ ] [ file get rollback-source-file ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: smart-usage ( word -- definitions )
|
||||
\ f or usage [
|
||||
dup method-body? [
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
: outside-usages ( seq -- usages )
|
||||
dup [
|
||||
over smart-usage [ pathname? not ] subset seq-diff
|
||||
] curry { } map>assoc ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: splitting tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[ { 1 2 3 } 0 group ] unit-test-fails
|
||||
[ { 1 2 3 } 0 group ] must-fail
|
||||
|
||||
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: temporary
|
|||
|
||||
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
|
||||
|
||||
[ ] [ 10 [ [ -1000000 <sbuf> ] catch drop ] times ] unit-test
|
||||
[ ] [ 10 [ [ -1000000 <sbuf> ] ignore-errors ] times ] unit-test
|
||||
|
||||
[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test
|
||||
|
||||
|
@ -31,7 +31,7 @@ IN: temporary
|
|||
[ t ] [ "abc" "abd" <=> 0 < ] unit-test
|
||||
[ t ] [ "z" "abd" <=> 0 > ] unit-test
|
||||
|
||||
[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test
|
||||
[ 0 10 "hello" subseq ] must-fail
|
||||
|
||||
[ "Replacing+spaces+with+plus" ]
|
||||
[
|
||||
|
@ -43,8 +43,8 @@ unit-test
|
|||
[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test
|
||||
[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test
|
||||
|
||||
[ 1 "" nth ] unit-test-fails
|
||||
[ -6 "hello" nth ] unit-test-fails
|
||||
[ 1 "" nth ] must-fail
|
||||
[ -6 "hello" nth ] must-fail
|
||||
|
||||
[ t ] [ "hello world" dup >vector >string = ] unit-test
|
||||
|
||||
|
@ -55,8 +55,7 @@ unit-test
|
|||
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
|
||||
|
||||
! Random tester found this
|
||||
[ { "kernel-error" 3 12 -7 } ]
|
||||
[ [ 2 -7 resize-string ] catch ] unit-test
|
||||
[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
|
||||
|
||||
! Make sure 24-bit strings work
|
||||
"hello world" "s" set
|
||||
|
|
|
@ -51,7 +51,8 @@ HELP: os
|
|||
"openbsd"
|
||||
"netbsd"
|
||||
"solaris"
|
||||
"windows"
|
||||
"wince"
|
||||
"winnt"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -22,7 +22,7 @@ splitting assocs ;
|
|||
os "wince" = ; foldable
|
||||
|
||||
: winnt? ( -- ? )
|
||||
os "windows" = ; foldable
|
||||
os "winnt" = ; foldable
|
||||
|
||||
: windows? ( -- ? )
|
||||
wince? winnt? or ; foldable
|
||||
|
|
|
@ -9,4 +9,4 @@ IN: temporary
|
|||
yield
|
||||
|
||||
[ ] [ 0.3 sleep ] unit-test
|
||||
[ "hey" sleep ] unit-test-fails
|
||||
[ "hey" sleep ] must-fail
|
||||
|
|
|
@ -55,7 +55,7 @@ C: <point> point
|
|||
|
||||
"IN: temporary TUPLE: point z y ;" eval
|
||||
|
||||
[ "p" get point-x ] unit-test-fails
|
||||
[ "p" get point-x ] must-fail
|
||||
[ 200 ] [ "p" get point-y ] unit-test
|
||||
[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
|
||||
|
||||
|
@ -97,7 +97,7 @@ TUPLE: delegate-clone ;
|
|||
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
|
||||
|
||||
! Compiler regression
|
||||
[ t ] [ [ t length ] catch no-method-object ] unit-test
|
||||
[ t length ] [ no-method-object t eq? ] must-fail-with
|
||||
|
||||
[ "<constructor-test>" ]
|
||||
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
|
||||
|
@ -123,7 +123,7 @@ TUPLE: yo-momma ;
|
|||
[ ] [ \ yo-momma forget ] unit-test
|
||||
[ f ] [ \ yo-momma typemap get values memq? ] unit-test
|
||||
|
||||
[ f ] [ \ yo-momma interned? ] unit-test
|
||||
[ f ] [ \ yo-momma crossref get at ] unit-test
|
||||
] with-compilation-unit
|
||||
|
||||
TUPLE: loc-recording ;
|
||||
|
@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class
|
|||
[
|
||||
"IN: temporary C: <not-a-tuple-class> not-a-tuple-class"
|
||||
eval
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[ t ] [
|
||||
"not-a-tuple-class" "temporary" lookup symbol?
|
||||
] unit-test
|
||||
|
||||
! Missing check
|
||||
[ not-a-tuple-class construct-boa ] unit-test-fails
|
||||
[ not-a-tuple-class construct-empty ] unit-test-fails
|
||||
[ not-a-tuple-class construct-boa ] must-fail
|
||||
[ not-a-tuple-class construct-empty ] must-fail
|
||||
|
||||
TUPLE: erg's-reshape-problem a b c d ;
|
||||
|
||||
|
@ -234,8 +234,6 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
|
||||
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
|
||||
] catch [ check-tuple? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
|
||||
] [ [ check-tuple? ] is? ] must-fail-with
|
||||
|
|
|
@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors
|
|||
continuations random growable classes ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ 10 [ [ -1000000 <vector> ] catch drop ] times ] unit-test
|
||||
[ ] [ 10 [ [ -1000000 <vector> ] ignore-errors ] times ] unit-test
|
||||
|
||||
[ 3 ] [ [ t f t ] length ] unit-test
|
||||
[ 3 ] [ V{ t f t } length ] unit-test
|
||||
|
||||
[ -3 V{ } nth ] unit-test-fails
|
||||
[ 3 V{ } nth ] unit-test-fails
|
||||
[ 3 54.3 nth ] unit-test-fails
|
||||
[ -3 V{ } nth ] must-fail
|
||||
[ 3 V{ } nth ] must-fail
|
||||
[ 3 54.3 nth ] must-fail
|
||||
|
||||
[ "hey" [ 1 2 ] set-length ] unit-test-fails
|
||||
[ "hey" V{ 1 2 } set-length ] unit-test-fails
|
||||
[ "hey" [ 1 2 ] set-length ] must-fail
|
||||
[ "hey" V{ 1 2 } set-length ] must-fail
|
||||
|
||||
[ 3 ] [ 3 0 <vector> [ set-length ] keep length ] unit-test
|
||||
[ "yo" ] [
|
||||
"yo" 4 1 <vector> [ set-nth ] keep 4 swap nth
|
||||
] unit-test
|
||||
|
||||
[ 1 V{ } nth ] unit-test-fails
|
||||
[ -1 V{ } set-length ] unit-test-fails
|
||||
[ 1 V{ } nth ] must-fail
|
||||
[ -1 V{ } set-length ] must-fail
|
||||
[ V{ } ] [ [ ] >vector ] unit-test
|
||||
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
|
||||
|
||||
|
@ -64,8 +64,8 @@ IN: temporary
|
|||
[ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test
|
||||
[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test
|
||||
[ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test
|
||||
[ "funny-stack" get pop ] unit-test-fails
|
||||
[ "funny-stack" get pop ] unit-test-fails
|
||||
[ "funny-stack" get pop ] must-fail
|
||||
[ "funny-stack" get pop ] must-fail
|
||||
[ ] [ "funky" "funny-stack" get push ] unit-test
|
||||
[ "funky" ] [ "funny-stack" get pop ] unit-test
|
||||
|
||||
|
|
|
@ -124,15 +124,12 @@ HELP: refresh
|
|||
{ $values { "prefix" string } }
|
||||
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
|
||||
|
||||
HELP: require-all-error
|
||||
{ $values { "vocabs" "a sequence of vocabularies" } }
|
||||
{ $description "Throws a " { $link require-all-error } "." }
|
||||
{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ;
|
||||
|
||||
HELP: refresh-all
|
||||
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
|
||||
|
||||
{ refresh refresh-all } related-words
|
||||
|
||||
HELP: vocab-file-contents
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
|
||||
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-file-contents
|
||||
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
|
||||
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
|
||||
|
|
|
@ -18,16 +18,6 @@ debugger compiler.units ;
|
|||
[ t ]
|
||||
[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
|
||||
|
||||
! This vocab should not exist, but just in case...
|
||||
[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test
|
||||
|
||||
2 [
|
||||
[ T{ no-vocab f "core" } ]
|
||||
[ [ "core" require ] catch ] unit-test
|
||||
] times
|
||||
|
||||
[ f ] [ "core" vocab ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"kernel" vocab-files
|
||||
"kernel" vocab vocab-files
|
||||
|
@ -59,7 +49,7 @@ IN: temporary
|
|||
0 "count-me" set-global
|
||||
|
||||
2 [
|
||||
[ "vocabs.loader.test.a" require ] unit-test-fails
|
||||
[ "vocabs.loader.test.a" require ] must-fail
|
||||
|
||||
[ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test
|
||||
|
||||
|
@ -73,14 +63,12 @@ IN: temporary
|
|||
|
||||
[ 2 ] [ "count-me" get-global ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"IN: vocabs.loader.test.a v-l-t-a-hello"
|
||||
<string-reader>
|
||||
"resource:core/vocabs/loader/test/a/a.factor"
|
||||
parse-stream
|
||||
] catch [ forward-error? ] is?
|
||||
] unit-test
|
||||
[
|
||||
"IN: vocabs.loader.test.a v-l-t-a-hello"
|
||||
<string-reader>
|
||||
"resource:core/vocabs/loader/test/a/a.factor"
|
||||
parse-stream
|
||||
] [ [ no-word? ] is? ] must-fail-with
|
||||
|
||||
0 "count-me" set-global
|
||||
|
||||
|
@ -97,7 +85,7 @@ IN: temporary
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ "vocabs.loader.test.b" require ] unit-test-fails
|
||||
[ "vocabs.loader.test.b" require ] must-fail
|
||||
|
||||
[ 1 ] [ "count-me" get-global ] unit-test
|
||||
|
||||
|
@ -131,8 +119,7 @@ IN: temporary
|
|||
[ "kernel" vocab where ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "vocabs.loader.test.d" require ] catch
|
||||
[ :1 ] when
|
||||
[ "vocabs.loader.test.d" require ] [ :1 ] recover
|
||||
"vocabs.loader.test.d" vocab-source-loaded?
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -148,16 +148,32 @@ SYMBOL: load-help?
|
|||
dup update-roots
|
||||
dup modified-sources swap modified-docs ;
|
||||
|
||||
: require-restart { { "Ignore this vocabulary" t } } ;
|
||||
: load-error. ( vocab error -- )
|
||||
"==== " write >r
|
||||
dup vocab-name swap f >vocab-link write-object ":" print nl
|
||||
r> print-error ;
|
||||
|
||||
: require-all ( seq -- )
|
||||
[
|
||||
TUPLE: require-all-error vocabs ;
|
||||
|
||||
: require-all-error ( vocabs -- )
|
||||
[ vocab-name ] map
|
||||
\ require-all-error construct-boa throw ;
|
||||
|
||||
M: require-all-error summary
|
||||
drop "The require-all operation failed" ;
|
||||
|
||||
: require-all ( vocabs -- )
|
||||
dup length 1 = [ first require ] [
|
||||
[
|
||||
[ require ]
|
||||
[ require-restart rethrow-restarts 2drop ]
|
||||
recover
|
||||
] each
|
||||
] with-compiler-errors ;
|
||||
[
|
||||
[ [ require ] [ 2array , ] recover ] each
|
||||
] { } make
|
||||
dup empty? [ drop ] [
|
||||
dup [ nl load-error. ] assoc-each
|
||||
keys require-all-error
|
||||
] if
|
||||
] with-compiler-errors
|
||||
] if ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
2dup
|
||||
|
@ -190,22 +206,3 @@ load-vocab-hook set-global
|
|||
M: vocab where vocab-where ;
|
||||
|
||||
M: vocab-link where vocab-where ;
|
||||
|
||||
: vocab-file-contents ( vocab name -- seq )
|
||||
vocab-path+ dup [
|
||||
?resource-path dup exists? [
|
||||
<file-reader> lines
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: set-vocab-file-contents ( seq vocab name -- )
|
||||
dupd vocab-path+ [
|
||||
?resource-path
|
||||
<file-writer> [ [ print ] each ] with-stream
|
||||
] [
|
||||
"The " swap vocab-name
|
||||
" vocabulary was not loaded from the file system"
|
||||
3append throw
|
||||
] ?if ;
|
||||
|
|
|
@ -76,7 +76,7 @@ HELP: all-words
|
|||
|
||||
HELP: forget-vocab
|
||||
{ $values { "vocab" string } }
|
||||
{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." }
|
||||
{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." }
|
||||
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
|
||||
|
||||
HELP: load-vocab-hook
|
||||
|
|
|
@ -14,9 +14,7 @@ $nl
|
|||
{ $subsection lookup }
|
||||
"Words can output their name and vocabulary:"
|
||||
{ $subsection word-name }
|
||||
{ $subsection word-vocabulary }
|
||||
"Testing if a word object is part of a vocabulary:"
|
||||
{ $subsection interned? } ;
|
||||
{ $subsection word-vocabulary } ;
|
||||
|
||||
ARTICLE: "uninterned-words" "Uninterned words"
|
||||
"A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "."
|
||||
|
@ -369,18 +367,6 @@ HELP: delimiter?
|
|||
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
|
||||
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
|
||||
|
||||
HELP: interned
|
||||
{ $class-description "The class of words defined in the " { $link dictionary } "." }
|
||||
{ $examples
|
||||
{ $example "\\ + interned? ." "t" }
|
||||
{ $example "gensym interned? ." "f" }
|
||||
} ;
|
||||
|
||||
HELP: rename-word
|
||||
{ $values { "word" word } { "newname" string } { "newvocab" string } }
|
||||
{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." }
|
||||
{ $side-effects "word" } ;
|
||||
|
||||
HELP: make-flushable
|
||||
{ $values { "word" word } }
|
||||
{ $description "Declares a word as " { $link POSTPONE: flushable } "." }
|
||||
|
|
|
@ -54,22 +54,14 @@ GENERIC: testing
|
|||
|
||||
[ f ] [ \ testing generic? ] unit-test
|
||||
|
||||
[ f ] [ gensym interned? ] unit-test
|
||||
|
||||
: forgotten ;
|
||||
: another-forgotten ;
|
||||
|
||||
[ f ] [ \ forgotten interned? ] unit-test
|
||||
|
||||
FORGET: forgotten
|
||||
|
||||
[ f ] [ \ another-forgotten interned? ] unit-test
|
||||
|
||||
FORGET: another-forgotten
|
||||
: another-forgotten ;
|
||||
|
||||
[ t ] [ \ + interned? ] unit-test
|
||||
|
||||
! I forgot remove-crossref calls!
|
||||
: fee ;
|
||||
: foe fee ;
|
||||
|
@ -87,7 +79,7 @@ FORGET: foe
|
|||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
\ * usage [ word? ] subset [ interned? not ] subset empty?
|
||||
\ * usage [ word? ] subset [ crossref? ] all?
|
||||
] unit-test
|
||||
|
||||
DEFER: calls-a-gensym
|
||||
|
@ -118,7 +110,7 @@ M: array freakish ;
|
|||
[ t ] [ \ bar \ freakish usage member? ] unit-test
|
||||
|
||||
DEFER: x
|
||||
[ t ] [ [ x ] catch undefined? ] unit-test
|
||||
[ x ] [ undefined? ] must-fail-with
|
||||
|
||||
[ ] [ "no-loc" "temporary" create drop ] unit-test
|
||||
[ f ] [ "no-loc" "temporary" lookup where ] unit-test
|
||||
|
@ -149,10 +141,8 @@ SYMBOL: quot-uses-b
|
|||
|
||||
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "IN: temporary : undef-test ; << undef-test >>" eval ] catch
|
||||
[ undefined? ] is?
|
||||
] unit-test
|
||||
[ "IN: temporary : undef-test ; << undef-test >>" eval ]
|
||||
[ [ undefined? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: temporary GENERIC: symbol-generic" eval
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: words
|
||||
USING: arrays definitions graphs assocs kernel kernel.private
|
||||
slots.private math namespaces sequences strings vectors sbufs
|
||||
quotations assocs hashtables sorting math.parser words.private
|
||||
vocabs ;
|
||||
vocabs combinators ;
|
||||
IN: words
|
||||
|
||||
: word ( -- word ) \ word get-global ;
|
||||
|
||||
|
@ -65,13 +65,20 @@ SYMBOL: bootstrapping?
|
|||
: bootstrap-word ( word -- target )
|
||||
[ target-word ] [ ] if-bootstrapping ;
|
||||
|
||||
PREDICATE: word interned dup target-word eq? ;
|
||||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
||||
GENERIC# (quot-uses) 1 ( obj assoc -- )
|
||||
|
||||
M: object (quot-uses) 2drop ;
|
||||
|
||||
M: interned (quot-uses) dupd set-at ;
|
||||
M: word (quot-uses)
|
||||
>r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
|
||||
|
||||
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
|
||||
|
||||
|
@ -92,6 +99,7 @@ SYMBOL: compiled-crossref
|
|||
compiled-crossref global [ H{ } assoc-like ] change-at
|
||||
|
||||
: compiled-xref ( word dependencies -- )
|
||||
[ drop crossref? ] assoc-subset
|
||||
2dup "compiled-uses" set-word-prop
|
||||
compiled-crossref get add-vertex* ;
|
||||
|
||||
|
@ -122,7 +130,7 @@ SYMBOL: changed-words
|
|||
over redefined
|
||||
over set-word-def
|
||||
dup changed-word
|
||||
dup word-vocabulary [ dup xref ] when drop ;
|
||||
dup crossref? [ dup xref ] when drop ;
|
||||
|
||||
: define-declared ( word def effect -- )
|
||||
pick swap "declared-effect" set-word-prop
|
||||
|
@ -191,24 +199,17 @@ M: word where "loc" word-prop ;
|
|||
|
||||
M: word set-where swap "loc" set-word-prop ;
|
||||
|
||||
GENERIC: (forget-word) ( word -- )
|
||||
GENERIC: forget-word ( word -- )
|
||||
|
||||
M: interned (forget-word)
|
||||
dup word-name swap word-vocabulary vocab-words delete-at ;
|
||||
: (forget-word) ( word -- )
|
||||
dup "forgotten" word-prop [
|
||||
dup delete-xref
|
||||
dup delete-compiled-xref
|
||||
dup word-name over word-vocabulary vocab-words delete-at
|
||||
dup t "forgotten" set-word-prop
|
||||
] unless drop ;
|
||||
|
||||
M: word (forget-word)
|
||||
drop ;
|
||||
|
||||
: rename-word ( word newname newvocab -- )
|
||||
pick (forget-word)
|
||||
pick set-word-vocabulary
|
||||
over set-word-name
|
||||
reveal ;
|
||||
|
||||
: forget-word ( word -- )
|
||||
dup delete-xref
|
||||
dup delete-compiled-xref
|
||||
(forget-word) ;
|
||||
M: word forget-word (forget-word) ;
|
||||
|
||||
M: word forget* forget-word ;
|
||||
|
||||
|
|
|
@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ;
|
|||
] unit-test
|
||||
|
||||
[ "testing" ] [
|
||||
"\u0004\u0007testing" <string-reader> [ asn-syntax read-ber ] with-stream
|
||||
"\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-stream
|
||||
] unit-test
|
||||
|
||||
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
|
||||
"0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus"
|
||||
"0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
|
||||
<string-reader> [ asn-syntax read-ber ] with-stream
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ;
|
|||
: fib ( m -- n )
|
||||
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
||||
|
||||
! HINTS: fib { fixnum float } ;
|
||||
!
|
||||
: ack ( m n -- x )
|
||||
over zero? [
|
||||
nip 1+
|
||||
|
@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ;
|
|||
] if
|
||||
] if ;
|
||||
|
||||
! HINTS: ack fixnum fixnum ;
|
||||
|
||||
: tak ( x y z -- t )
|
||||
pick pick swap < [
|
||||
[ rot 1- -rot tak ] 3keep
|
||||
|
@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ;
|
|||
2nip
|
||||
] if ;
|
||||
|
||||
! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ;
|
||||
|
||||
: recursive ( n -- )
|
||||
3 over ack . flush
|
||||
dup 27.0 + fib . flush
|
||||
|
|
|
@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;
|
|||
[ 855 ] [ 21 852 3 <foo> 855 swap with-foo-baz foo-baz ] unit-test
|
||||
[ 1 ] [ 21 852 3 <foo> 1 swap with-foo-bing foo-bing ] unit-test
|
||||
|
||||
[ 100 0 0 <foo> ] unit-test-fails
|
||||
[ 0 5000 0 <foo> ] unit-test-fails
|
||||
[ 0 0 10 <foo> ] unit-test-fails
|
||||
[ 100 0 0 <foo> ] must-fail
|
||||
[ 0 5000 0 <foo> ] must-fail
|
||||
[ 0 0 10 <foo> ] must-fail
|
||||
|
||||
[ 100 0 with-foo-bar ] unit-test-fails
|
||||
[ 5000 0 with-foo-baz ] unit-test-fails
|
||||
[ 10 0 with-foo-bing ] unit-test-fails
|
||||
[ 100 0 with-foo-bar ] must-fail
|
||||
[ 5000 0 with-foo-baz ] must-fail
|
||||
[ 10 0 with-foo-bing ] must-fail
|
||||
|
||||
[ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 <foo> ] unit-test
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
|
||||
USING: kernel io io.files io.launcher tools.deploy.backend
|
||||
system namespaces sequences splitting math.parser
|
||||
unix prettyprint tools.time calendar bake vars ;
|
||||
USING: kernel io io.files io.launcher hashtables tools.deploy.backend
|
||||
system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators ;
|
||||
|
||||
IN: builder
|
||||
|
||||
|
@ -13,102 +14,122 @@ IN: builder
|
|||
,[ dup timestamp-day ]
|
||||
,[ dup timestamp-hour ]
|
||||
,[ timestamp-minute ] }
|
||||
[ number>string 2 CHAR: 0 pad-left ] map "-" join ;
|
||||
[ pad-00 ] map "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: quote ( str -- str ) "'" swap "'" 3append ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
"cat" ,
|
||||
"| mutt -s" ,[ quote ]
|
||||
"-x" %[ builder-recipients get ]
|
||||
}
|
||||
" " join system drop ;
|
||||
|
||||
{ +stdin+ , }
|
||||
{ +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
|
||||
}
|
||||
>hashtable run-process drop ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" , %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-binary ( -- name )
|
||||
os
|
||||
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
|
||||
{ "windows" [ "./factor-nt.exe" ] }
|
||||
[ drop "./factor" ] }
|
||||
case ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: stamp
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build ( -- )
|
||||
|
||||
datestamp >stamp
|
||||
datestamp >stamp
|
||||
|
||||
"/builds/factor" cd
|
||||
"git pull git://factorcode.org/git/factor.git" system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: git pull" "/dev/null" email-file
|
||||
"builder: git pull" throw
|
||||
]
|
||||
if
|
||||
"/builds/factor" cd
|
||||
|
||||
{ "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" }
|
||||
run-process process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: git pull" email-string
|
||||
"builder: git pull" throw
|
||||
]
|
||||
if
|
||||
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
"git clone /builds/factor" system drop
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
|
||||
"factor" cd
|
||||
{ "git" "clone" "/builds/factor" } run-process drop
|
||||
|
||||
{ "git" "show" } <process-stream>
|
||||
[ readln ] with-stream
|
||||
" " split second
|
||||
"../git-id" <file-writer> [ print ] with-stream
|
||||
"factor" cd
|
||||
|
||||
"make clean" system drop
|
||||
{ "git" "show" } <process-stream>
|
||||
[ readln ] with-stream
|
||||
" " split second
|
||||
"../git-id" <file-writer> [ print ] with-stream
|
||||
|
||||
"make " target " > ../compile-log" 3append system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: vm compile" "../compile-log" email-file
|
||||
"builder: vm compile" throw
|
||||
] if
|
||||
{ "make" "clean" } run-process drop
|
||||
|
||||
"wget http://factorcode.org/images/latest/" boot-image-name append system
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: image download" "/dev/null" email-file
|
||||
"builder: image download" throw
|
||||
] if
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable run-process process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: vm compile" "../compile-log" email-file
|
||||
"builder: vm compile" throw
|
||||
] if
|
||||
|
||||
[
|
||||
"./factor -i=" boot-image-name " -no-user-init > ../boot-log"
|
||||
3append
|
||||
system
|
||||
]
|
||||
benchmark nip
|
||||
"../boot-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: bootstrap" "../boot-log" email-file
|
||||
"builder: bootstrap" throw
|
||||
] if
|
||||
[ "http://factorcode.org/images/latest/" boot-image-name append download ]
|
||||
[ "builder: image download" email-string ]
|
||||
recover
|
||||
|
||||
[
|
||||
"./factor -e='USE: tools.browser load-everything' > ../load-everything-log"
|
||||
system
|
||||
] benchmark nip
|
||||
"../load-everything-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: load-everything" "../load-everything-log" email-file
|
||||
"builder: load-everything" throw
|
||||
] if
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable
|
||||
[ run-process process-status ]
|
||||
benchmark nip "../boot-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: bootstrap" "../boot-log" email-file
|
||||
"builder: bootstrap" throw
|
||||
] if
|
||||
|
||||
;
|
||||
`{
|
||||
{ +arguments+
|
||||
{ ,[ factor-binary ] "-e=USE: tools.browser load-everything" } }
|
||||
{ +stdout+ "../load-everything-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable [ run-process process-status ] benchmark nip
|
||||
"../load-everything-time" <file-writer> [ . ] with-stream
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: load-everything" "../load-everything-log" email-file
|
||||
"builder: load-everything" throw
|
||||
] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -1,14 +1,14 @@
|
|||
USING: arrays calendar kernel math sequences tools.test
|
||||
continuations system ;
|
||||
|
||||
[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test
|
||||
[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test
|
||||
[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
|
||||
[ f ] [ 1900 leap-year? ] unit-test
|
||||
[ t ] [ 1904 leap-year? ] unit-test
|
||||
|
|
|
@ -9,7 +9,7 @@ circular strings ;
|
|||
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
|
||||
[ "test" ] [ "test" <circular> >string ] unit-test
|
||||
|
||||
[ "test" <circular> 5 swap nth ] unit-test-fails
|
||||
[ "test" <circular> 5 swap nth ] must-fail
|
||||
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
|
@ -18,7 +18,7 @@ circular strings ;
|
|||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
||||
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
|
||||
[ "foo" <circular> CHAR: b 3 rot set-nth ] unit-test-fails
|
||||
[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
|
||||
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
|
||||
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: combinators.lib kernel math math.ranges random sequences
|
||||
tools.test inference continuations arrays vectors ;
|
||||
tools.test tools.test.inference continuations arrays vectors ;
|
||||
IN: temporary
|
||||
|
||||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||
|
@ -8,26 +8,25 @@ IN: temporary
|
|||
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
|
||||
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
|
||||
|
||||
: infers? [ infer drop ] curry catch not ;
|
||||
|
||||
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
|
||||
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
|
||||
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
|
||||
{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test
|
||||
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
|
||||
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
|
||||
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
|
||||
{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test
|
||||
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
|
||||
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
|
||||
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
|
||||
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
|
||||
[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test
|
||||
[ [ sq ] 3apply ] must-infer
|
||||
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
|
||||
[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test
|
||||
[ [ dup 2^ 2array ] 5 napply ] must-infer
|
||||
|
||||
! &&
|
||||
|
||||
|
|
|
@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions"
|
|||
"A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:"
|
||||
{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
|
||||
"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:"
|
||||
{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" }
|
||||
{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" }
|
||||
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
|
||||
|
||||
ARTICLE: { "concurrency" "futures" } "Futures"
|
||||
|
|
|
@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words
|
|||
match quotations concurrency.private ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
make-mailbox
|
||||
|
@ -67,15 +69,12 @@ IN: temporary
|
|||
] unit-test
|
||||
|
||||
|
||||
[ "crash" ] [
|
||||
[
|
||||
[
|
||||
[
|
||||
"crash" throw
|
||||
] spawn-link drop
|
||||
receive
|
||||
]
|
||||
catch
|
||||
] unit-test
|
||||
"crash" throw
|
||||
] spawn-link drop
|
||||
receive
|
||||
] [ "crash" = ] must-fail-with
|
||||
|
||||
[ 50 ] [
|
||||
[ 50 ] future ?future
|
||||
|
@ -115,7 +114,7 @@ SYMBOL: value
|
|||
! this is fixed (via a timeout).
|
||||
! [
|
||||
! [ "this should propogate" throw ] future ?future
|
||||
! ] unit-test-fails
|
||||
! ] must-fail
|
||||
|
||||
[ ] [
|
||||
[ "this should not propogate" throw ] future drop
|
||||
|
|
|
@ -73,7 +73,7 @@ PRIVATE>
|
|||
|
||||
: mailbox-get?* ( pred mailbox timeout -- obj )
|
||||
2over >r >r (mailbox-block-unless-pred) r> r>
|
||||
mailbox-data delete-node ; inline
|
||||
mailbox-data delete-node-if ; inline
|
||||
|
||||
: mailbox-get? ( pred mailbox -- obj )
|
||||
f mailbox-get?* ;
|
||||
|
@ -166,7 +166,7 @@ M: process send ( message process -- )
|
|||
PRIVATE>
|
||||
|
||||
: spawn-link ( quot -- process )
|
||||
[ catch [ rethrow-linked ] when* ] curry
|
||||
[ [ rethrow-linked ] recover ] curry
|
||||
[ ((spawn)) ] curry (spawn-link) ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -10,7 +10,7 @@ USING: coroutines kernel sequences prettyprint tools.test math ;
|
|||
[ 1+ coyield* ] cocreate ;
|
||||
|
||||
test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
|
||||
[ test2 42 over coresume . dup *coresume . drop ] unit-test-fails
|
||||
[ test2 42 over coresume . dup *coresume . drop ] must-fail
|
||||
{ 43 } [ 42 test2 coresume ] unit-test
|
||||
|
||||
: test3 ( -- co )
|
||||
|
|
|
@ -2,10 +2,10 @@ USING: continuations crypto.xor kernel strings tools.test ;
|
|||
IN: temporary
|
||||
|
||||
! No key
|
||||
[ T{ no-xor-key f } ] [ [ "" dup xor-crypt ] catch ] unit-test
|
||||
[ T{ no-xor-key f } ] [ [ { } dup xor-crypt ] catch ] unit-test
|
||||
[ T{ no-xor-key f } ] [ [ V{ } dup xor-crypt ] catch ] unit-test
|
||||
[ T{ no-xor-key f } ] [ [ "" "asdf" dupd xor-crypt xor-crypt ] catch ] unit-test
|
||||
[ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
|
||||
[ { } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
|
||||
[ V{ } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
|
||||
[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
|
||||
|
||||
! a xor a = 0
|
||||
[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test
|
||||
|
|
|
@ -10,7 +10,6 @@ C: <db> db ( handle -- obj )
|
|||
! HOOK: db-create db ( str -- )
|
||||
! HOOK: db-drop db ( str -- )
|
||||
GENERIC: db-open ( db -- )
|
||||
GENERIC: db-close ( db -- )
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
|
||||
|
|
|
@ -1,27 +1,18 @@
|
|||
! See http://factorcode.org/license.txt
|
||||
! Copyright (C) 2007 Berlin Brown
|
||||
! Date: 1/17/2007
|
||||
!
|
||||
! libs/mysql/libmysql.factor
|
||||
!
|
||||
! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! Adapted from mysql.h and mysql.c
|
||||
! Tested with MySQL version - 5.0.24a
|
||||
USING: alien alien.syntax combinators kernel system ;
|
||||
IN: db.mysql.ffi
|
||||
|
||||
IN: mysql
|
||||
USING: alien kernel ;
|
||||
|
||||
"mysql" {
|
||||
<< "mysql" {
|
||||
{ [ win32? ] [ "libmySQL.dll" "stdcall" ] }
|
||||
{ [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
|
||||
{ [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
|
||||
} cond add-library
|
||||
} cond add-library >>
|
||||
|
||||
LIBRARY: mysql
|
||||
|
||||
! ===============================================
|
||||
! mysql.c
|
||||
! ===============================================
|
||||
|
||||
FUNCTION: void* mysql_init ( void* mysql ) ;
|
||||
FUNCTION: char* mysql_error ( void* mysql ) ;
|
||||
FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ;
|
||||
|
@ -32,4 +23,3 @@ FUNCTION: void mysql_free_result ( void* result ) ;
|
|||
FUNCTION: char** mysql_fetch_row ( void* result ) ;
|
||||
FUNCTION: int mysql_num_fields ( void* result ) ;
|
||||
FUNCTION: ulong mysql_affected_rows ( void* mysql ) ;
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for license.
|
||||
! Adapted from mysql.h and mysql.c
|
||||
! Tested with MySQL version - 5.0.24a
|
||||
USING: kernel alien io prettyprint sequences
|
||||
namespaces arrays math db.mysql.ffi system ;
|
||||
IN: db.mysql.lib
|
||||
|
||||
SYMBOL: my-conn
|
||||
|
||||
TUPLE: mysql-db handle host user password db port ;
|
||||
TUPLE: mysql-statement ;
|
||||
TUPLE: mysql-result-set ;
|
||||
|
||||
: new-mysql ( -- conn )
|
||||
f mysql_init ;
|
||||
|
||||
: mysql-error ( mysql -- )
|
||||
[ mysql_error throw ] when* ;
|
||||
|
||||
: mysql-connect ( mysql-connection -- )
|
||||
new-mysql over set-mysql-db-handle
|
||||
dup {
|
||||
mysql-db-handle
|
||||
mysql-db-host
|
||||
mysql-db-user
|
||||
mysql-db-password
|
||||
mysql-db-db
|
||||
mysql-db-port
|
||||
} get-slots f 0 mysql_real_connect mysql-error ;
|
||||
|
||||
! =========================================================
|
||||
! Low level mysql utility definitions
|
||||
! =========================================================
|
||||
|
||||
: (mysql-query) ( mysql-connection query -- ret )
|
||||
>r mysql-db-handle r> mysql_query ;
|
||||
|
||||
! : (mysql-result) ( mysql-connection -- ret )
|
||||
! [ mysql-db-handle mysql_use_result ] keep
|
||||
! [ set-mysql-connection-resulthandle ] keep ;
|
||||
|
||||
! : (mysql-affected-rows) ( mysql-connection -- n )
|
||||
! mysql-connection-mysqlconn mysql_affected_rows ;
|
||||
|
||||
! : (mysql-free-result) ( mysql-connection -- )
|
||||
! mysql-connection-resulthandle drop ;
|
||||
|
||||
! : (mysql-row) ( mysql-connection -- row )
|
||||
! mysql-connection-resulthandle mysql_fetch_row ;
|
||||
|
||||
! : (mysql-num-cols) ( mysql-connection -- n )
|
||||
! mysql-connection-resulthandle mysql_num_fields ;
|
||||
|
||||
! : mysql-char*-nth ( index object -- str )
|
||||
! #! Utility based on 'char*-nth' to perform an additional sanity check on the value
|
||||
! #! extracted from the array of strings.
|
||||
! void*-nth [ alien>char-string ] [ "" ] if* ;
|
||||
|
||||
! : mysql-row>seq ( object n -- seq )
|
||||
! [ swap mysql-char*-nth ] map-with ;
|
||||
|
||||
! : (mysql-result>seq) ( seq -- seq )
|
||||
! my-conn get (mysql-row) dup [
|
||||
! my-conn get (mysql-num-cols) mysql-row>seq
|
||||
! over push
|
||||
! (mysql-result>seq)
|
||||
! ] [ drop ] if
|
||||
! ! Perform needed cleanup on fetched results
|
||||
! my-conn get (mysql-free-result) ;
|
||||
|
||||
! : mysql-query ( query -- ret )
|
||||
! >r my-conn get r> (mysql-query) drop
|
||||
! my-conn get (mysql-result) ;
|
||||
|
||||
! : mysql-command ( query -- n )
|
||||
! mysql-query drop
|
||||
! my-conn get (mysql-affected-rows) ;
|
|
@ -0,0 +1,58 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for license.
|
||||
USING: alien continuations io kernel prettyprint sequences
|
||||
db db.mysql.ffi ;
|
||||
IN: db.mysql
|
||||
|
||||
TUPLE: mysql-db handle host user password db port ;
|
||||
TUPLE: mysql-statement ;
|
||||
TUPLE: mysql-result-set ;
|
||||
|
||||
M: mysql-db db-open ( mysql-db -- )
|
||||
;
|
||||
|
||||
M: mysql-db dispose ( mysql-db -- )
|
||||
mysql-db-handle mysql_close ;
|
||||
|
||||
|
||||
M: mysql-db <simple-statement> ( str -- statement )
|
||||
;
|
||||
|
||||
M: mysql-db <prepared-statement> ( str -- statement )
|
||||
;
|
||||
|
||||
M: mysql-statement prepare-statement ( statement -- )
|
||||
;
|
||||
|
||||
M: mysql-statement bind-statement* ( statement -- )
|
||||
;
|
||||
|
||||
M: mysql-statement rebind-statement ( statement -- )
|
||||
;
|
||||
|
||||
M: mysql-statement execute-statement ( statement -- )
|
||||
;
|
||||
|
||||
M: mysql-statement query-results ( query -- result-set )
|
||||
;
|
||||
|
||||
M: mysql-result-set #rows ( result-set -- n )
|
||||
;
|
||||
|
||||
M: mysql-result-set #columns ( result-set -- n )
|
||||
;
|
||||
|
||||
M: mysql-result-set row-column ( result-set n -- obj )
|
||||
;
|
||||
|
||||
M: mysql-result-set advance-row ( result-set -- ? )
|
||||
;
|
||||
|
||||
M: mysql-db begin-transaction ( -- )
|
||||
;
|
||||
|
||||
M: mysql-db commit-transaction ( -- )
|
||||
;
|
||||
|
||||
M: mysql-db rollback-transaction ( -- )
|
||||
;
|
|
@ -1,6 +1,5 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! adapted from libpq-fe.h version 7.4.7
|
||||
! tested on debian linux with postgresql 8.1
|
||||
|
||||
USING: alien alien.syntax combinators system ;
|
||||
|
|
|
@ -14,7 +14,7 @@ IN: temporary
|
|||
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] catch drop
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
||||
|
@ -83,7 +83,7 @@ IN: temporary
|
|||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
|
|
|
@ -1,42 +1,28 @@
|
|||
USING: io io.files io.launcher kernel namespaces
|
||||
prettyprint tools.test db.sqlite db db.sql sequences
|
||||
prettyprint tools.test db.sqlite db sequences
|
||||
continuations ;
|
||||
IN: temporary
|
||||
|
||||
! "sqlite3 -init test.txt test.db"
|
||||
|
||||
IN: scratchpad
|
||||
: test.db "extra/db/sqlite/test.db" resource-path ;
|
||||
|
||||
IN: temporary
|
||||
: (create-db) ( -- str )
|
||||
[
|
||||
"sqlite3 -init " %
|
||||
test.db %
|
||||
" " %
|
||||
test.db %
|
||||
] "" make ;
|
||||
[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
|
||||
|
||||
: create-db ( -- ) (create-db) run-process drop ;
|
||||
[ ] [
|
||||
test.db [
|
||||
"create table person (name varchar(30), country varchar(30))" sql-command
|
||||
"insert into person values('John', 'America')" sql-command
|
||||
"insert into person values('Jane', 'New Zealand')" sql-command
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[ ] [ test.db delete-file ] unit-test
|
||||
|
||||
[ ] [ create-db ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
|
||||
test.db [
|
||||
"select * from person" sql-query
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
[ { { "John" "America" } } ] [
|
||||
test.db [
|
||||
"select * from person where name = :name and country = :country"
|
||||
<simple-statement> [
|
||||
|
@ -52,15 +38,10 @@ IN: temporary
|
|||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
|
||||
[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
[ ] [
|
||||
test.db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
|
@ -83,7 +64,7 @@ IN: temporary
|
|||
"oops" throw
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] unit-test-fails
|
||||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
test.db [
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db db.sql
|
||||
USING: alien arrays assocs classes compiler db
|
||||
hashtables io.files kernel math math.parser namespaces
|
||||
prettyprint sequences strings tuples alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi ;
|
||||
|
|
|
@ -39,7 +39,7 @@ M: tuple-class group-words
|
|||
: define-mimic ( group mimicker mimicked -- )
|
||||
>r >r group-words r> r> [
|
||||
pick "methods" word-prop at dup
|
||||
[ method-def <method> spin define-method ] [ 3drop ] if
|
||||
[ method-def spin define-method ] [ 3drop ] if
|
||||
] 2curry each ;
|
||||
|
||||
: MIMIC:
|
||||
|
|
|
@ -36,7 +36,7 @@ M: dummy-destructor destruct ( obj -- )
|
|||
dup destroy-always
|
||||
"foo" throw
|
||||
] with-destructors
|
||||
] catch drop dummy-obj-destroyed?
|
||||
] ignore-errors dummy-obj-destroyed?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
@ -45,6 +45,6 @@ M: dummy-destructor destruct ( obj -- )
|
|||
dup destroy-later
|
||||
"foo" throw
|
||||
] with-destructors
|
||||
] catch drop dummy-obj-destroyed?
|
||||
] ignore-errors dummy-obj-destroyed?
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -1,12 +1,13 @@
|
|||
USING: alien.syntax kernel math prettyprint system
|
||||
combinators vocabs.loader hardware-info.backend ;
|
||||
USING: alien.syntax kernel math prettyprint
|
||||
combinators vocabs.loader hardware-info.backend system ;
|
||||
IN: hardware-info
|
||||
|
||||
: kb. ( x -- ) 10 2^ /f . ;
|
||||
: megs. ( x -- ) 20 2^ /f . ;
|
||||
: gigs. ( x -- ) 30 2^ /f . ;
|
||||
|
||||
<< {
|
||||
<<
|
||||
{
|
||||
{ [ windows? ] [ "hardware-info.windows" ] }
|
||||
{ [ linux? ] [ "hardware-info.linux" ] }
|
||||
{ [ macosx? ] [ "hardware-info.macosx" ] }
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue