From 93eb74476e776f044283ce61354852037a5c0cb1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 20:04:46 -0600 Subject: [PATCH 001/104] add with-file-in docs, update a couple of usages --- core/io/files/files-docs.factor | 15 +++++++++++++++ extra/tar/tar.factor | 5 ++--- extra/tools/browser/browser.factor | 4 ++-- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0b9a748eb8..99f2d42542 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,6 +52,21 @@ HELP: { $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: with-file-in +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file is unreadable." } ; + +HELP: with-file-out +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: with-file-appender +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 20e997185d..e15d9511a3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) - ] with-stream ; - + ] with-file-out ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..167c238069 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -10,7 +10,7 @@ IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ lines ] [ drop f ] if ; + [ file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-stream + [ [ print ] each ] with-file-out ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From a2e6c372136f35a1d62a8add94293efbd8b52649 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 18:30:20 -0600 Subject: [PATCH 002/104] simplify builder.test --- extra/builder/builder.factor | 9 +++++-- extra/builder/test/test.factor | 48 ++++++++++++++++++++++------------ 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5e992ccc81..caa381ba5d 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,8 +1,8 @@ -USING: kernel io io.files io.launcher hashtables tools.deploy.backend +USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators ; + combinators bootstrap.image ; IN: builder @@ -82,6 +82,11 @@ VAR: stamp ] if + { + "git" "pull" "--no-summary" + "http://dharmatech.onigirihouse.com/factor.git" "master" + } run-process process-status + "/builds/" stamp> append make-directory "/builds/" stamp> append cd diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index fb9c62e2aa..2a867b1fbc 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,28 +7,42 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test +! : do-load ( -- ) +! [ +! [ load-everything ] +! [ require-all-error-vocabs "../load-everything-log" log-object ] +! recover +! ] +! "../load-everything-time" log-runtime ; + : do-load ( -- ) - [ - [ load-everything ] - [ require-all-error-vocabs "../load-everything-log" log-object ] - recover - ] - "../load-everything-time" log-runtime ; + [ try-everything ] "../load-everything-time" log-runtime + dup empty? + [ drop ] + [ "../load-everything-log" log-object ] + if ; + +! : do-tests ( -- ) +! "" child-vocabs +! [ vocab-source-loaded? ] subset +! [ vocab-tests-path ] map +! [ dup [ ?resource-path exists? ] when ] subset +! [ dup run-test ] { } map>assoc +! [ second empty? not ] subset +! dup empty? +! [ drop ] +! [ +! "../failing-tests" +! [ [ nl failures. ] assoc-each ] +! with-stream +! ] +! if ; : do-tests ( -- ) - "" child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - [ dup run-test ] { } map>assoc - [ second empty? not ] subset + run-all-tests keys dup empty? [ drop ] - [ - "../failing-tests" - [ [ nl failures. ] assoc-each ] - with-stream - ] + [ "../failing-tests" log-object ] if ; : do-all ( -- ) do-load do-tests ; From 1c3efa89d214ad2b4f9f6b468de2519c6bdbae2c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 19:50:26 -0600 Subject: [PATCH 003/104] builder improvements (download-image, simpler do-all) --- extra/builder/builder.factor | 12 ++++++------ extra/builder/test/test.factor | 24 ------------------------ 2 files changed, 6 insertions(+), 30 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index caa381ba5d..9af79efb29 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,7 +2,7 @@ USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators bootstrap.image ; + combinators bootstrap.image bootstrap.image.download ; IN: builder @@ -70,7 +70,6 @@ VAR: stamp "pull" "--no-summary" "git://factorcode.org/git/factor.git" - ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status @@ -85,7 +84,7 @@ VAR: stamp { "git" "pull" "--no-summary" "http://dharmatech.onigirihouse.com/factor.git" "master" - } run-process process-status + } run-process drop "/builds/" stamp> append make-directory "/builds/" stamp> append cd @@ -112,14 +111,15 @@ VAR: stamp "builder: vm compile" throw ] if - [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ my-arch download-image ] + [ ] [ "builder: image download" email-string ] - recover + cleanup `{ { +arguments+ { ,[ factor-binary ] - ,[ "-i=" boot-image-name append ] + ,[ "-i=" my-boot-image-name append ] "-no-user-init" } } { +stdout+ "../boot-log" } diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 2a867b1fbc..c887c668e6 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,14 +7,6 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test -! : do-load ( -- ) -! [ -! [ load-everything ] -! [ require-all-error-vocabs "../load-everything-log" log-object ] -! recover -! ] -! "../load-everything-time" log-runtime ; - : do-load ( -- ) [ try-everything ] "../load-everything-time" log-runtime dup empty? @@ -22,22 +14,6 @@ IN: builder.test [ "../load-everything-log" log-object ] if ; -! : do-tests ( -- ) -! "" child-vocabs -! [ vocab-source-loaded? ] subset -! [ vocab-tests-path ] map -! [ dup [ ?resource-path exists? ] when ] subset -! [ dup run-test ] { } map>assoc -! [ second empty? not ] subset -! dup empty? -! [ drop ] -! [ -! "../failing-tests" -! [ [ nl failures. ] assoc-each ] -! with-stream -! ] -! if ; - : do-tests ( -- ) run-all-tests keys dup empty? From fb67a7621be9e22a85f76a79d8c0ef10d206b06b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:52:40 -0600 Subject: [PATCH 004/104] Cleanup --- extra/logging/server/server.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..601237ba81 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -25,9 +25,11 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; +: multiline-header 20 CHAR: - ; foldable + : (write-message) ( msg word-name level multi? -- ) [ - "[" write 20 CHAR: - write "] " write + "[" write multiline-header write "] " write ] [ "[" write now (timestamp>rfc3339) "] " write ] if From 7cdcac3fc97f33d23344985c376bc043ad3b22e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:09 -0600 Subject: [PATCH 005/104] Add another unit test --- core/compiler/test/optimizer.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 7ee4ebfd1c..987aace00a 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -300,3 +300,4 @@ TUPLE: silly-tuple a b ; [ f ] [ \ sequence \ hashcode* should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From f67ab9a6897ea24982c8049e821740864b6e1f77 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:23 -0600 Subject: [PATCH 006/104] Multi-methods work in progress --- .../multi-methods/multi-methods-tests.factor | 12 ++ extra/multi-methods/multi-methods.factor | 117 ++++++++++++------ 2 files changed, 88 insertions(+), 41 deletions(-) diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index a0769dffda..1c68cbe540 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ; [ fixnum ] [ 3 hook-test ] unit-test 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 827d64b95f..9a74cc65e8 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,12 +3,12 @@ USING: kernel math sequences vectors classes combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units ; +debugger io compiler.units kernel.private effects ; IN: multi-methods -TUPLE: method loc def ; +GENERIC: generic-prologue ( combination -- quot ) -: { set-method-def } \ method construct ; +GENERIC: method-prologue ( combination -- quot ) : maximal-element ( seq quot -- n elt ) dupd [ @@ -25,6 +25,7 @@ TUPLE: method loc def ; [ { { [ 2dup eq? ] [ 0 ] } + { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] } { [ 2dup class< ] [ -1 ] } { [ 2dup swap class< ] [ 1 ] } { [ t ] [ 0 ] } @@ -54,8 +55,37 @@ TUPLE: method loc def ; : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: method-defs ( methods -- methods' ) - [ method-def ] assoc-map ; +: make-method-def ( quot classes generic -- quot ) + [ + swap [ declare ] curry % + "multi-combination" word-prop method-prologue % + % + ] [ ] make ; + +TUPLE: method word def classes generic loc ; + +PREDICATE: word method-body "multi-method" word-prop >boolean ; + +M: method-body stack-effect + "multi-method" word-prop method-generic stack-effect ; + +: method-word-name ( classes generic -- string ) + [ + word-name % + "-(" % [ "," % ] [ word-name % ] interleave ")" % + ] "" make ; + +: ( quot classes generic -- word ) + #! We xref here because the "multi-method" word-prop isn't + #! set yet so crossref? yields f. + [ make-method-def ] 2keep + method-word-name f + dup rot define + dup xref ; + +: ( quot classes generic -- method ) + [ ] 3keep f \ method construct-boa + dup method-word over "multi-method" set-word-prop ; TUPLE: no-method arguments generic ; @@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ; ] if ; : multi-dispatch-quot ( methods generic -- quot ) - >r - [ [ >r multi-predicate r> ] assoc-map ] keep argument-count + >r [ + [ + >r multi-predicate r> method-word 1quotation + ] assoc-map + ] keep argument-count r> [ no-method ] 2curry swap reverse alist>quot ; @@ -98,36 +131,36 @@ M: no-method error. methods congruify-methods sorted-methods keys [ niceify-method ] map stack. ; -GENERIC: perform-combination ( word combination -- quot ) - TUPLE: standard-combination ; -: standard-combination ( methods generic -- quot ) - >r congruify-methods sorted-methods r> multi-dispatch-quot ; +M: standard-combination method-prologue drop [ ] ; -M: standard-combination perform-combination - drop [ methods method-defs ] keep standard-combination ; +M: standard-combination generic-prologue drop [ ] ; + +: make-generic ( generic -- quot ) + dup "multi-combination" word-prop generic-prologue swap + [ methods congruify-methods sorted-methods ] keep + multi-dispatch-quot append ; TUPLE: hook-combination var ; -M: hook-combination perform-combination - hook-combination-var [ get ] curry swap methods - [ method-defs [ [ drop ] swap append ] assoc-map ] keep - standard-combination append ; +M: hook-combination method-prologue + drop [ drop ] ; -: make-generic ( word -- ) - dup dup "multi-combination" word-prop perform-combination - define ; +M: hook-combination generic-prologue + hook-combination-var [ get ] curry ; -: init-methods ( word -- ) - dup "multi-methods" word-prop - H{ } assoc-like - "multi-methods" set-word-prop ; +: update-generic ( word -- ) + dup make-generic define ; : define-generic ( word combination -- ) - dupd "multi-combination" set-word-prop - dup init-methods - make-generic ; + over "multi-combination" word-prop over = [ + 2drop + ] [ + dupd "multi-combination" set-word-prop + dup H{ } clone "multi-methods" set-word-prop + update-generic + ] if ; : define-standard-generic ( word -- ) T{ standard-combination } define-generic ; @@ -146,29 +179,31 @@ M: hook-combination perform-combination : with-methods ( word quot -- ) over >r >r "multi-methods" word-prop - r> call r> make-generic ; inline + r> call r> update-generic ; inline -: add-method ( method classes word -- ) +: define-method ( quot classes generic -- ) + >r [ bootstrap-word ] map r> + [ ] 2keep [ set-at ] with-methods ; -: forget-method ( classes word -- ) +: forget-method ( classes generic -- ) [ delete-at ] with-methods ; -: parse-method ( -- method classes word method-spec ) - parse-definition 2 cut - over >r - >r first2 swap r> -rot - r> first2 swap add* >array ; +: method>spec ( method -- spec ) + dup method-classes swap method-generic add* ; + +: parse-method ( -- quot classes generic ) + parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method >r add-method r> r> + >r parse-method [ define-method ] 2keep add* r> remember-definition ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot add-method ; parsing + scan-word 1array scan-word parse-definition + -rot define-method ; parsing ! Definition protocol. We qualify core generics here USE: qualified @@ -202,7 +237,7 @@ PREDICATE: array method-spec unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method method-loc [ ] [ second where ] ?if ; + dup unclip method [ method-loc ] [ second where ] ?if ; syntax:M: method-spec set-where unclip method set-method-loc ; @@ -211,11 +246,11 @@ syntax:M: method-spec definer drop \ METHOD: \ ; ; syntax:M: method-spec definition - unclip method method-def ; + unclip method dup [ method-def ] when ; syntax:M: method-spec synopsis* dup definer. unclip pprint* pprint* ; syntax:M: method-spec forget* - unclip [ delete-at ] with-methods ; + unclip forget-method ; From 492e569b627ed7826b6fd9b4a946fa7c15e379d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:52 -0600 Subject: [PATCH 007/104] 'about' now requires first --- extra/help/help.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/help/help.factor b/extra/help/help.factor index aefbf2aba2..77b9f699aa 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel namespaces parser prettyprint sequences -words assocs definitions generic quotations effects -slots continuations tuples debugger combinators -vocabs help.stylesheet help.topics help.crossref help.markup -sorting classes ; +words assocs definitions generic quotations effects slots +continuations tuples debugger combinators vocabs help.stylesheet +help.topics help.crossref help.markup sorting classes +vocabs.loader ; IN: help GENERIC: word-help* ( word -- content ) @@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup require dup vocab [ ] [ "No such vocabulary: " swap append throw ] ?if From 52b5c5a0682644327c22d7e10f8fe16d006e67a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:48:51 -0600 Subject: [PATCH 008/104] Reorganize compiler tests --- core/alien/c-types/c-types.factor | 2 + core/alien/compiler/compiler-tests.factor | 356 ++++++++++++++++++ core/compiler/compiler-tests.factor | 28 +- .../curry-tests.factor} | 0 core/compiler/test/curry/curry.factor | 0 .../float-tests.factor} | 0 core/compiler/test/float/float.factor | 0 core/compiler/test/generic.factor | 30 -- core/compiler/test/ifte.factor | 131 ------- .../intrinsics-tests.factor} | 0 .../test/intrinsics/intrinsics.factor | 0 .../redefine-tests.factor} | 0 core/compiler/test/redefine/redefine.factor | 0 core/compiler/test/simple.factor | 71 ---- core/compiler/test/simple/simple-tests.factor | 227 +++++++++++ core/compiler/test/simple/simple.factor | 0 .../stack-trace-tests.factor} | 0 .../test/stack-trace/stack-trace.factor | 0 .../templates-early-tests.factor} | 0 .../templates-early/templates-early.factor | 0 .../templates-tests.factor} | 0 core/compiler/test/templates/templates.factor | 0 .../tuples-tests.factor} | 0 core/compiler/test/tuples/tuples.factor | 0 core/inference/class/class-tests.factor | 10 + core/inference/known-words/known-words.factor | 17 + core/inference/transforms/transforms.factor | 4 +- core/math/bitfields/bitfields-tests.factor | 11 +- core/optimizer/optimizer-tests.factor | 303 +++++++++++++++ core/parser/parser.factor | 2 +- 30 files changed, 936 insertions(+), 256 deletions(-) create mode 100755 core/alien/compiler/compiler-tests.factor mode change 100644 => 100755 core/compiler/compiler-tests.factor rename core/compiler/test/{curry.factor => curry/curry-tests.factor} (100%) create mode 100644 core/compiler/test/curry/curry.factor rename core/compiler/test/{float.factor => float/float-tests.factor} (100%) create mode 100644 core/compiler/test/float/float.factor delete mode 100644 core/compiler/test/generic.factor delete mode 100755 core/compiler/test/ifte.factor rename core/compiler/test/{intrinsics.factor => intrinsics/intrinsics-tests.factor} (100%) create mode 100644 core/compiler/test/intrinsics/intrinsics.factor rename core/compiler/test/{redefine.factor => redefine/redefine-tests.factor} (100%) create mode 100644 core/compiler/test/redefine/redefine.factor delete mode 100755 core/compiler/test/simple.factor create mode 100755 core/compiler/test/simple/simple-tests.factor create mode 100644 core/compiler/test/simple/simple.factor rename core/compiler/test/{stack-trace.factor => stack-trace/stack-trace-tests.factor} (100%) create mode 100644 core/compiler/test/stack-trace/stack-trace.factor rename core/compiler/test/{templates-early.factor => templates-early/templates-early-tests.factor} (100%) create mode 100644 core/compiler/test/templates-early/templates-early.factor rename core/compiler/test/{templates.factor => templates/templates-tests.factor} (100%) create mode 100644 core/compiler/test/templates/templates.factor rename core/compiler/test/{tuples.factor => tuples/tuples-tests.factor} (100%) create mode 100644 core/compiler/test/tuples/tuples.factor mode change 100644 => 100755 core/math/bitfields/bitfields-tests.factor create mode 100755 core/optimizer/optimizer-tests.factor diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 6c46cb946a..ed0721a7ff 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,8 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +: little-endian? ( -- ? ) 1 *char 1 = ; foldable + TUPLE: c-type boxer prep unboxer getter setter diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor new file mode 100755 index 0000000000..c0c3733afa --- /dev/null +++ b/core/alien/compiler/compiler-tests.factor @@ -0,0 +1,356 @@ +IN: temporary +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "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 + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +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 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +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 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + data-gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke data-gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke data-gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] 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 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke code-gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +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 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +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 7 8 9 ffi_test_12 ] unit-test + +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +FUNCTION: test-struct-7 ffi_test_30 ; + +[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test + +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + data-gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] string-out +] unit-test + +: callback-5 + "void" { } "cdecl" [ data-gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +cpu "arm" = [ + [ "testing" ] [ + "testing" callback-5a callback_test_1 + ] unit-test +] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor old mode 100644 new mode 100755 index bd9b26ce6d..7e4e79437d --- a/core/compiler/compiler-tests.factor +++ b/core/compiler/compiler-tests.factor @@ -1,21 +1,7 @@ -USING: io.files tools.test sequences namespaces kernel -compiler.units ; - -{ - "templates-early" - "simple" - "intrinsics" - "float" - "generic" - "ifte" - "templates" - "optimizer" - "redefine" - "stack-trace" - "alien" - "curry" - "tuples" -} -[ "resource:core/compiler/test/" swap ".factor" 3append ] map -[ run-test ] map -[ failures get push-all ] each +IN: temporary +USING: tools.browser tools.test kernel sequences vocabs ; + +"compiler.test" child-vocabs empty? [ + "compiler.test" load-children + "compiler.test" test +] when diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry/curry-tests.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/test/curry/curry-tests.factor diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/float.factor b/core/compiler/test/float/float-tests.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/test/float/float-tests.factor diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/generic.factor b/core/compiler/test/generic.factor deleted file mode 100644 index c54dbd753d..0000000000 --- a/core/compiler/test/generic.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: compiler generic tools.test math kernel words arrays -sequences quotations ; - -GENERIC: single-combination-test - -M: object single-combination-test drop ; -M: f single-combination-test nip ; -M: array single-combination-test drop ; -M: integer single-combination-test drop ; - -[ 2 3 ] [ 2 3 t single-combination-test ] unit-test -[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test -[ 2 f ] [ 2 3 f single-combination-test ] unit-test - -DEFER: single-combination-test-2 - -: single-combination-test-4 - dup [ single-combination-test-2 ] when ; - -: single-combination-test-3 - drop 3 ; - -GENERIC: single-combination-test-2 -M: object single-combination-test-2 single-combination-test-3 ; -M: f single-combination-test-2 single-combination-test-4 ; - -[ 3 ] [ t single-combination-test-2 ] unit-test -[ 3 ] [ 3 single-combination-test-2 ] unit-test -[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor deleted file mode 100755 index 802cad5032..0000000000 --- a/core/compiler/test/ifte.factor +++ /dev/null @@ -1,131 +0,0 @@ -IN: temporary -USING: alien strings compiler tools.test math kernel words -math.private combinators ; - -: dummy-if-1 t [ ] [ ] if ; - -[ ] [ dummy-if-1 ] unit-test - -: dummy-if-2 f [ ] [ ] if ; - -[ ] [ dummy-if-2 ] unit-test - -: dummy-if-3 t [ 1 ] [ 2 ] if ; - -[ 1 ] [ dummy-if-3 ] unit-test - -: dummy-if-4 f [ 1 ] [ 2 ] if ; - -[ 2 ] [ dummy-if-4 ] unit-test - -: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; - -[ 1 ] [ dummy-if-5 ] unit-test - -: dummy-if-6 - dup 1 fixnum<= [ - drop 1 - ] [ - 1 fixnum- dup 1 fixnum- fixnum+ - ] if ; - -[ 17 ] [ 10 dummy-if-6 ] unit-test - -: dead-code-rec - t [ - 3.2 - ] [ - dead-code-rec - ] if ; - -[ 3.2 ] [ dead-code-rec ] unit-test - -: one-rec [ f one-rec ] [ "hi" ] if ; - -[ "hi" ] [ t one-rec ] unit-test - -: after-if-test - t [ ] [ ] if 5 ; - -[ 5 ] [ after-if-test ] unit-test - -DEFER: countdown-b - -: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; -: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; - -[ ] [ 10 countdown-b ] unit-test - -: dummy-when-1 t [ ] when ; - -[ ] [ dummy-when-1 ] unit-test - -: dummy-when-2 f [ ] when ; - -[ ] [ dummy-when-2 ] unit-test - -: dummy-when-3 dup [ dup fixnum* ] when ; - -[ 16 ] [ 4 dummy-when-3 ] unit-test -[ f ] [ f dummy-when-3 ] unit-test - -: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; - -[ 64 f ] [ f 4 dummy-when-4 ] unit-test -[ f t ] [ t f dummy-when-4 ] unit-test - -: dummy-when-5 f [ dup fixnum* ] when ; - -[ f ] [ f dummy-when-5 ] unit-test - -: dummy-unless-1 t [ ] unless ; - -[ ] [ dummy-unless-1 ] unit-test - -: dummy-unless-2 f [ ] unless ; - -[ ] [ dummy-unless-2 ] unit-test - -: dummy-unless-3 dup [ drop 3 ] unless ; - -[ 3 ] [ f dummy-unless-3 ] unit-test -[ 4 ] [ 4 dummy-unless-3 ] unit-test - -! Test cond expansion -[ "even" ] [ - [ - 2 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "odd" ] [ - [ - 3 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "neither" ] [ - [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } - } cond - ] compile-call -] unit-test - -[ 3 ] [ - [ - 3 { - { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } - } cond - ] compile-call -] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics-tests.factor similarity index 100% rename from core/compiler/test/intrinsics.factor rename to core/compiler/test/intrinsics/intrinsics-tests.factor diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine/redefine-tests.factor similarity index 100% rename from core/compiler/test/redefine.factor rename to core/compiler/test/redefine/redefine-tests.factor diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor deleted file mode 100755 index 6f5cb33c1a..0000000000 --- a/core/compiler/test/simple.factor +++ /dev/null @@ -1,71 +0,0 @@ -USING: compiler tools.test kernel kernel.private -combinators.private ; -IN: temporary - -! Test empty word -[ ] [ [ ] compile-call ] unit-test - -! Test literals -[ 1 ] [ [ 1 ] compile-call ] unit-test -[ 31 ] [ [ 31 ] compile-call ] unit-test -[ 255 ] [ [ 255 ] compile-call ] unit-test -[ -1 ] [ [ -1 ] compile-call ] unit-test -[ 65536 ] [ [ 65536 ] compile-call ] unit-test -[ -65536 ] [ [ -65536 ] compile-call ] unit-test -[ "hey" ] [ [ "hey" ] compile-call ] unit-test - -! Calls -: no-op ; - -[ ] [ [ no-op ] compile-call ] unit-test -[ 3 ] [ [ no-op 3 ] compile-call ] unit-test -[ 3 ] [ [ 3 no-op ] compile-call ] unit-test - -: bar 4 ; - -[ 4 ] [ [ bar no-op ] compile-call ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test - -[ ] [ no-op ] unit-test - -! Conditionals - -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test - -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test - -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test - -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test - -! Labels - -: recursive ( ? -- ) [ f recursive ] when ; inline - -[ ] [ t [ recursive ] compile-call ] unit-test - -[ ] [ t recursive ] unit-test - -! Make sure error reporting works - -[ [ dup ] compile-call ] must-fail -[ [ drop ] compile-call ] must-fail - -! Regression - -[ ] [ [ callstack ] compile-call drop ] unit-test - -! Regression - -: empty ; - -[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor new file mode 100755 index 0000000000..3f4f6451a3 --- /dev/null +++ b/core/compiler/test/simple/simple-tests.factor @@ -0,0 +1,227 @@ +USING: compiler tools.test kernel kernel.private +combinators.private math.private math combinators strings +alien arrays ; +IN: temporary + +! Test empty word +[ ] [ [ ] compile-call ] unit-test + +! Test literals +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test + +! Calls +: no-op ; + +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test + +: bar 4 ; + +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test + +[ ] [ no-op ] unit-test + +! Conditionals + +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test + +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test + +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test + +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test + +! Labels + +: recursive ( ? -- ) [ f recursive ] when ; inline + +[ ] [ t [ recursive ] compile-call ] unit-test + +[ ] [ t recursive ] unit-test + +! Make sure error reporting works + +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail + +! Regression + +[ ] [ [ callstack ] compile-call drop ] unit-test + +! Regression + +: empty ; + +[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test + +: dummy-if-1 t [ ] [ ] if ; + +[ ] [ dummy-if-1 ] unit-test + +: dummy-if-2 f [ ] [ ] if ; + +[ ] [ dummy-if-2 ] unit-test + +: dummy-if-3 t [ 1 ] [ 2 ] if ; + +[ 1 ] [ dummy-if-3 ] unit-test + +: dummy-if-4 f [ 1 ] [ 2 ] if ; + +[ 2 ] [ dummy-if-4 ] unit-test + +: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; + +[ 1 ] [ dummy-if-5 ] unit-test + +: dummy-if-6 + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup 1 fixnum- fixnum+ + ] if ; + +[ 17 ] [ 10 dummy-if-6 ] unit-test + +: dead-code-rec + t [ + 3.2 + ] [ + dead-code-rec + ] if ; + +[ 3.2 ] [ dead-code-rec ] unit-test + +: one-rec [ f one-rec ] [ "hi" ] if ; + +[ "hi" ] [ t one-rec ] unit-test + +: after-if-test + t [ ] [ ] if 5 ; + +[ 5 ] [ after-if-test ] unit-test + +DEFER: countdown-b + +: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; +: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; + +[ ] [ 10 countdown-b ] unit-test + +: dummy-when-1 t [ ] when ; + +[ ] [ dummy-when-1 ] unit-test + +: dummy-when-2 f [ ] when ; + +[ ] [ dummy-when-2 ] unit-test + +: dummy-when-3 dup [ dup fixnum* ] when ; + +[ 16 ] [ 4 dummy-when-3 ] unit-test +[ f ] [ f dummy-when-3 ] unit-test + +: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; + +[ 64 f ] [ f 4 dummy-when-4 ] unit-test +[ f t ] [ t f dummy-when-4 ] unit-test + +: dummy-when-5 f [ dup fixnum* ] when ; + +[ f ] [ f dummy-when-5 ] unit-test + +: dummy-unless-1 t [ ] unless ; + +[ ] [ dummy-unless-1 ] unit-test + +: dummy-unless-2 f [ ] unless ; + +[ ] [ dummy-unless-2 ] unit-test + +: dummy-unless-3 dup [ drop 3 ] unless ; + +[ 3 ] [ f dummy-unless-3 ] unit-test +[ 4 ] [ 4 dummy-unless-3 ] unit-test + +! Test cond expansion +[ "even" ] [ + [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "odd" ] [ + [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "neither" ] [ + [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond + ] compile-call +] unit-test + +[ 3 ] [ + [ + 3 { + { [ dup fixnum? ] [ ] } + { [ t ] [ drop t ] } + } cond + ] compile-call +] unit-test + +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; +M: array single-combination-test drop ; +M: integer single-combination-test drop ; + +[ 2 3 ] [ 2 3 t single-combination-test ] unit-test +[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test +[ 2 f ] [ 2 3 f single-combination-test ] unit-test + +DEFER: single-combination-test-2 + +: single-combination-test-4 + dup [ single-combination-test-2 ] when ; + +: single-combination-test-3 + drop 3 ; + +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +[ 3 ] [ t single-combination-test-2 ] unit-test +[ 3 ] [ 3 single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/simple/simple.factor b/core/compiler/test/simple/simple.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace-tests.factor similarity index 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/test/stack-trace/stack-trace-tests.factor diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early/templates-early-tests.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/test/templates-early/templates-early-tests.factor diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates/templates-tests.factor similarity index 100% rename from core/compiler/test/templates.factor rename to core/compiler/test/templates/templates-tests.factor diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/tuples.factor b/core/compiler/test/tuples/tuples-tests.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/test/tuples/tuples-tests.factor diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3bd90a3aca..17cc3d3cf8 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -263,3 +263,13 @@ cell-bits 32 = [ \ fixnum-shift inlined? ] unit-test ] when + +[ t ] [ + [ B{ 1 0 } *short 0 number= ] + \ number= inlined? +] unit-test + +[ t ] [ + [ B{ 1 0 } *short 0 = ] + \ number= inlined? +] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6be3899acd..69e331a9bf 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -414,64 +414,81 @@ t over set-effect-terminated? \ make-flushable \ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell make-flushable \ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell make-flushable \ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 make-flushable \ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 make-flushable \ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 make-flushable \ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 make-flushable \ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 make-flushable \ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 make-flushable \ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 make-flushable \ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 make-flushable \ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float make-flushable \ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double make-flushable \ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell make-flushable \ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop \ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string make-flushable \ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien make-flushable \ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string make-flushable \ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien make-flushable \ alien-address { alien } { integer } "inferred-effect" set-word-prop \ alien-address make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index ad2bacc789..b1b56ca1a1 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform -\ flags [ flags [ ] curry ] 1 define-transform +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform ! Tuple operations : [get-slots] ( slots -- quot ) diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index c382d3352d..a10c0566f8 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,4 +1,4 @@ -USING: math math.bitfields tools.test kernel ; +USING: math math.bitfields tools.test kernel words ; IN: temporary [ 0 ] [ { } bitfield ] unit-test @@ -6,3 +6,12 @@ IN: temporary [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test [ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +[ t ] [ \ foo compiled? ] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor new file mode 100755 index 0000000000..232eb5a83a --- /dev/null +++ b/core/optimizer/optimizer-tests.factor @@ -0,0 +1,303 @@ +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 growable ; +IN: temporary + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +: 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 +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d54bf1c1f4..486c589134 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ; : ( text -- lexer ) 0 { set-lexer-text set-lexer-line } lexer construct - dup lexer-text empty? [ dup next-line ] unless ; + dup next-line ; : location ( -- loc ) file get lexer get lexer-line 2dup and From 59cc83c29614f33bd177ebfb2d8f40fd12fbffb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:05 -0600 Subject: [PATCH 009/104] Fix bugs in tools.test --- extra/tools/test/test.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 192a248161..2cbdc3d7c7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -81,7 +81,7 @@ M: expected-error summary "Traceback" swap third write-object ; : test-failures. ( assoc -- ) - dup [ + [ nl dup empty? [ drop @@ -90,15 +90,15 @@ M: expected-error summary "==== FAILING TESTS:" print [ swap vocab-heading. - [ nl failure. nl ] each + [ failure. nl ] each ] assoc-each ] if ] [ - drop "==== NOTHING TO TEST" print - ] if ; + "==== NOTHING TO TEST" print + ] if* ; : run-tests ( prefix -- failures ) - child-vocabs dup empty? [ f ] [ + child-vocabs dup empty? [ drop f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; From 6df325c16830f55c925fede788e997d8e4288099 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:30 -0600 Subject: [PATCH 010/104] Moved little-endian? to alien.c-types --- extra/io/unix/select/select.factor | 2 -- 1 file changed, 2 deletions(-) mode change 100644 => 100755 extra/io/unix/select/select.factor diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor old mode 100644 new mode 100755 index c28686d2f2..06e257a610 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for ! byte order differences on big endian platforms -: little-endian? 1 *char 1 = ; foldable - : munge ( i -- i' ) little-endian? [ BIN: 11000 bitxor ] unless ; inline From b14197fadcb607ffc84f9f05531c11e567cd0561 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:49 -0600 Subject: [PATCH 011/104] Remove obsolete files --- core/compiler/test/alien.factor | 356 ---------------------------- core/compiler/test/optimizer.factor | 303 ----------------------- 2 files changed, 659 deletions(-) delete mode 100755 core/compiler/test/alien.factor delete mode 100755 core/compiler/test/optimizer.factor diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor deleted file mode 100755 index 4adb1c234b..0000000000 --- a/core/compiler/test/alien.factor +++ /dev/null @@ -1,356 +0,0 @@ -IN: temporary -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -FUNCTION: int ffi_test_2 int x int y ; -[ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "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 - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -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 ] must-fail -[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -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 ] must-fail - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -FUNCTION: tiny ffi_test_17 int x ; - -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test - -[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] must-infer-as - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] must-fail - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; - -{ 3 1 } [ indirect-test-2 ] must-infer-as - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke data-gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] 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 ] must-fail - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke code-gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -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 ] must-fail - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -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 7 8 9 ffi_test_12 ] unit-test - -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -FUNCTION: test-struct-7 ffi_test_30 ; - -[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test - -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; - -FUNCTION: double ffi_test_32 test-struct-8 x int y ; - -[ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y - 3 ffi_test_32 -] unit-test - -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; - -FUNCTION: double ffi_test_33 test-struct-9 x int y ; - -[ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y - 3 ffi_test_33 -] unit-test - -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_34 test-struct-10 x int y ; - -[ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y - 3 ffi_test_34 -] unit-test - -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_35 test-struct-11 x int y ; - -[ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; - -: make-struct-12 - "test-struct-12" - [ set-test-struct-12-x ] keep ; - -FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; - -[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out -] unit-test - -: callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -cpu "arm" = [ - [ "testing" ] [ - "testing" callback-5a callback_test_1 - ] unit-test -] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor deleted file mode 100755 index 987aace00a..0000000000 --- a/core/compiler/test/optimizer.factor +++ /dev/null @@ -1,303 +0,0 @@ -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 growable ; -IN: temporary - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -: 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 -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From 7adb07bcc4354c8f32befc3cfce5242c6b11687e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:11:47 -0600 Subject: [PATCH 012/104] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f04811b72a..538ed847f0 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From 3f38bf18ec98e02af5a42422d167bc8122053b89 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:14:08 -0600 Subject: [PATCH 013/104] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index 538ed847f0..16a2e65a90 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From d41bfc64f1686af2a53fb9be984b8324763aee28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 17:00:42 -0600 Subject: [PATCH 014/104] Minor tests fix --- extra/tools/test/test.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2cbdc3d7c7..0b5e436e44 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,9 +61,14 @@ M: expected-error summary dup vocab-source-loaded? [ vocab-tests-path dup [ dup ?resource-path exists? [ - [ "temporary" forget-vocab ] with-compilation-unit + [ + "temporary" forget-vocab + ] with-compilation-unit dup run-file - [ dup forget-source ] with-compilation-unit + [ + dup forget-source + "temporary" forget-vocab + ] with-compilation-unit ] when ] when ] when drop ; From 5570f367a631dddd2e0f42078baa15641ed12567 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:09:59 -0600 Subject: [PATCH 015/104] builder: build-status variable --- extra/builder/builder.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) mode change 100755 => 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 index 9af79efb29..1c5f5ff3fd --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -59,8 +59,12 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : build ( -- ) + "running" build-status set-global + datestamp >stamp "/builds/factor" cd @@ -98,6 +102,8 @@ VAR: stamp { "make" "clean" } run-process drop + ! "vm" build-status set-global + `{ { +arguments+ { "make" ,[ target ] } } { +stdout+ "../compile-log" } @@ -116,6 +122,8 @@ VAR: stamp [ "builder: image download" email-string ] cleanup + ! "bootstrap" build-status set-global + `{ { +arguments+ { ,[ factor-binary ] @@ -133,6 +141,8 @@ VAR: stamp "builder: bootstrap" throw ] if + ! "test" build-status set-global + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop "../load-everything-log" exists? @@ -143,6 +153,8 @@ VAR: stamp [ "builder: failing tests" "../failing-tests" email-file ] when + ! "ready" build-status set-global + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 7b07ababba5a9f95d17fa9c67fbfe006d97916cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:16:12 -0600 Subject: [PATCH 016/104] add builder.server --- extra/builder/server/server.factor | 68 ++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 extra/builder/server/server.factor diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor new file mode 100644 index 0000000000..672de1e47d --- /dev/null +++ b/extra/builder/server/server.factor @@ -0,0 +1,68 @@ + +USING: kernel continuations namespaces threads match bake concurrency builder ; + +IN: builder.server + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ [ build ] in-thread ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread +! ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build-server ( -- ) + receive + { + { + "start" + [ + build-status get "idle" = + build-status get f = + or + [ + [ [ build ] [ drop ] recover "idle" build-status set-global ] + in-thread + ] + when + ] + } + + { + { ?from ?tag "status" } + [ `{ ?tag ,[ build-status get ] } ?from send ] + } + } + match-cond + build-server ; + From d7af06c75ae454e15097108af22f9544a7e6a7ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:13:05 -0600 Subject: [PATCH 017/104] Remove obsolete scripts --- misc/integration/deploy-size-test.factor | 28 ------- misc/integration/macosx-deploy.factor | 24 ------ misc/integration/macosx.sh | 43 ----------- misc/integration/test.sh | 93 ------------------------ misc/integration/unix-arm.sh | 10 --- misc/integration/unix-ppc.sh | 10 --- misc/integration/unix-x86.32.sh | 21 ------ misc/integration/unix-x86.64.sh | 10 --- misc/integration/x11-deploy.factor | 8 -- 9 files changed, 247 deletions(-) delete mode 100644 misc/integration/deploy-size-test.factor delete mode 100644 misc/integration/macosx-deploy.factor delete mode 100644 misc/integration/macosx.sh delete mode 100644 misc/integration/test.sh delete mode 100644 misc/integration/unix-arm.sh delete mode 100644 misc/integration/unix-ppc.sh delete mode 100644 misc/integration/unix-x86.32.sh delete mode 100644 misc/integration/unix-x86.64.sh delete mode 100644 misc/integration/x11-deploy.factor diff --git a/misc/integration/deploy-size-test.factor b/misc/integration/deploy-size-test.factor deleted file mode 100644 index 91cdaba293..0000000000 --- a/misc/integration/deploy-size-test.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: tools.deploy sequences io.files io.launcher io -kernel concurrency prettyprint ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-world" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - dup - "deploy-log/" over append - [ deploy ] with-stream - dup file-length 1024 /f - 2array -] parallel-map . diff --git a/misc/integration/macosx-deploy.factor b/misc/integration/macosx-deploy.factor deleted file mode 100644 index f1e6e7fe06..0000000000 --- a/misc/integration/macosx-deploy.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: tools.deploy.app sequences io.files io.launcher io -kernel concurrency ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - "deploy-log/" over append - [ deploy.app ] with-stream -] parallel-each diff --git a/misc/integration/macosx.sh b/misc/integration/macosx.sh deleted file mode 100644 index dafe9524c6..0000000000 --- a/misc/integration/macosx.sh +++ /dev/null @@ -1,43 +0,0 @@ -CPU=$1 - -if [ "$CPU" = "x86.32" ]; then - TARGET="macosx-x86" -elif [ "$CPU" = "ppc" ]; then - TARGET="macosx-ppc" - CPU = "macosx-ppc" -else - echo "Specify a CPU" - exit 1 -fi - -EXE=factor - -bash misc/integration/test.sh \ - $EXE \ - $CPU \ - $TARGET \ - no \ - no \ - no \ - "X11=1" \ - "-ui-backend=x11" \ - "-x11" || exit 1 - -echo "Testing deployment" -$EXE "misc/integration/x11-deploy.factor" -run=none $VM_LOG $BOOT_LOG /tmp/factor-$$ - - $EXE -i=$IMAGE \ - /tmp/factor-$$ \ - -run=none \ - >$LOAD_LOG $TEST_LOG $BENCHMARK_LOG [ deploy ] with-stream From 52d91bf0bc0a568ae4d561890cd0082b3410b387 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:15:29 -0600 Subject: [PATCH 018/104] Add try-process word --- extra/benchmark/bootstrap2/bootstrap2.factor | 2 +- extra/bootstrap/image/upload/upload.factor | 3 +-- extra/editors/emacs/emacs.factor | 2 +- extra/editors/textmate/textmate.factor | 2 +- extra/io/launcher/launcher-docs.factor | 10 ++++++++++ extra/io/launcher/launcher.factor | 9 +++++++++ extra/logging/parser/parser.factor | 10 +++++++--- extra/tools/deploy/backend/backend.factor | 5 ++++- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 9 files changed, 36 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/bootstrap/image/upload/upload.factor diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index 54bc73f4a1..f57e92e5e0 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -9,6 +9,6 @@ IN: benchmark.bootstrap2 "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , - ] { } make run-process drop ; + ] { } make try-process ; MAIN: bootstrap-benchmark diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor old mode 100644 new mode 100755 index a9f5d1dcd4..3b5ab4cb77 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ "scp" , boot-image-names % "checksums.txt" , destination , - ] { } make run-process - wait-for-process zero? [ "Upload failed" throw ] unless ; + ] { } make try-process ; : new-images ( -- ) make-images compute-checksums upload-images ; diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor index 31e0761043..966c4f368e 100755 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -8,7 +8,7 @@ IN: editors.emacs "--no-wait" , "+" swap number>string append , , - ] { } make run-process drop ; + ] { } make try-process ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor index 0145ccae81..12d45aa192 100755 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -5,6 +5,6 @@ IN: editors.textmate : textmate-location ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - run-process drop ; + try-process ; [ textmate-location ] edit-hook set-global diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4979f135ac..e414d98d65 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process-failed +{ $values { "code" "an exit status" } } +{ $description "Throws a " { $link process-failed } " error." } +{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ; + +HELP: try-process +{ $values { "desc" "a launch descriptor" } } +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -175,6 +184,7 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +{ $subsection try-process } "Stopping processes:" { $subsection kill-process } "Redirecting standard input and output to a pipe:" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f2ed59a591..7044004218 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +TUPLE: process-failed code ; + +: process-failed ( code -- * ) + process-failed construct-boa throw ; + +: try-process ( desc -- ) + run-process wait-for-process dup zero? + [ drop ] [ process-failed ] if ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f1cb7aa17e..f9bf97a442 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -2,13 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files -namespaces combinators combinators.lib logging.server ; +namespaces combinators combinators.lib logging.server +calendar ; IN: logging.parser : string-of satisfy [ >string ] <@ ; +SYMBOL: multiline + : 'date' - [ CHAR: ] eq? not ] string-of + multiline-header token [ drop multiline ] <@ + [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> "[" "]" surrounded-by ; : 'log-level' @@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser ) first malformed eq? ; : multiline? ( line -- ? ) - first first CHAR: - = ; + first multiline eq? ; : malformed-line "Warning: malformed log line:" print diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index c295f6369d..2439ef8636 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,7 +22,10 @@ IN: tools.deploy.backend +stdout+ +stderr+ set ] H{ } make-assoc dup duplex-stream-out dispose - copy-lines ; + dup copy-lines + process-stream-process wait-for-process zero? [ + "Deployment failed" throw + ] unless ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 1bbf198ea0..eb1a4af4a7 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process drop ; + { "touch" } swap add try-process ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process drop ; + { "rm" "-rf" } swap add try-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; From 20649302fa59634b8bf3fc5aa99f72b94f2d2c10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:35 -0600 Subject: [PATCH 019/104] Fix a couple of issues with futures --- extra/concurrency/concurrency-tests.factor | 14 +++++++--- extra/concurrency/concurrency.factor | 30 +++++++++++++--------- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index b6f62d1779..1a19ce7096 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -112,9 +112,9 @@ SYMBOL: value ! The following unit test blocks forever if the ! exception does not propogate. Uncomment when ! this is fixed (via a timeout). -! [ -! [ "this should propogate" throw ] future ?future -! ] must-fail +[ + [ "this should propogate" throw ] future ?future +] must-fail [ ] [ [ "this should not propogate" throw ] future drop @@ -127,4 +127,10 @@ SYMBOL: value [ f ] [ [ "testing unregistering on error" throw ] spawn 100 sleep process-pid get-process -] unit-test \ No newline at end of file +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index cf44ab125c..e4972c9030 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,29 +264,35 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; +TUPLE: future value processes ; + +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return #! a 'future' on the stack. The future can later be queried with #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - [ self send ] compose spawn ; + \ future construct-empty [ + [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - process-mailbox mailbox-get ; - -: parallel-map ( seq quot -- newseq ) - #! Spawn a process to apply quot to each element of seq, - #! joining the results into a sequence at the end. - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - #! Spawn a process to apply quot to each element of seq, - #! and waits for all processes to complete. - [ f ] compose parallel-map drop ; + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; TUPLE: promise fulfilled? value processes ; From f05cf861eb032f3215690557f16cda2bf4f57394 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:47 -0600 Subject: [PATCH 020/104] Fix USING: in io.launcher --- extra/io/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7044004218..4a6bbf46fb 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads -continuations ; +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility From f45f6879ab04d4d115ee91b21493471592971fb9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 23:28:06 -0600 Subject: [PATCH 021/104] Makefile: winnt target downloads dlls --- Makefile | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 05a185f643..9776027a59 100755 --- a/Makefile +++ b/Makefile @@ -123,7 +123,15 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -winnt-x86-32: +freetype6.dll: + wget http://factorcode.org/dlls/freetype6.dll + chmod 755 freetype6.dll + +zlib1.dll: + wget http://factorcode.org/dlls/zlib1.dll + chmod 755 zlib1.dll + +winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 winnt-x86-64: From d65bde09d1a0f6eca0511826eb60d7b493232e25 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:14 -0600 Subject: [PATCH 022/104] Fix bootstrap --- core/alien/c-types/c-types.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ed0721a7ff..fbd49cedbb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,9 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +DEFER: +DEFER: *char + : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type From cb2dc00762edf5101c3a5689f541cfec39a72252 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:24 -0600 Subject: [PATCH 023/104] Add MAIN: to bootstrap.image.download --- extra/bootstrap/image/download/download.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index deed045221..df559f49da 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -23,3 +23,7 @@ bootstrap.image sequences io ; "Boot image up to date" print drop ] if ; + +: download-my-image ( -- ) my-arch download-image ; + +MAIN: download-my-image From 6f0e64bb4cb5843174c67df58bdd6c5bb5639a76 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:30 -0600 Subject: [PATCH 024/104] Add some tags --- extra/concurrency/distributed/tags.txt | 1 + extra/cpu/8080/emulator/tags.txt | 2 +- extra/cpu/8080/tags.txt | 2 +- extra/cryptlib/tags.txt | 1 + extra/http/server/tags.txt | 1 + extra/ldap/tags.txt | 1 + extra/openssl/tags.txt | 1 + extra/smtp/tags.txt | 1 + extra/xml-rpc/tags.txt | 1 + extra/xml/tags.txt | 1 + 10 files changed, 10 insertions(+), 2 deletions(-) diff --git a/extra/concurrency/distributed/tags.txt b/extra/concurrency/distributed/tags.txt index f4274299b1..50cfa263f6 100644 --- a/extra/concurrency/distributed/tags.txt +++ b/extra/concurrency/distributed/tags.txt @@ -1 +1,2 @@ +enterprise extensions diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/emulator/tags.txt +++ b/extra/cpu/8080/emulator/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/tags.txt +++ b/extra/cpu/8080/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cryptlib/tags.txt b/extra/cryptlib/tags.txt index bb863cf9a0..b88f9848cd 100644 --- a/extra/cryptlib/tags.txt +++ b/extra/cryptlib/tags.txt @@ -1 +1,2 @@ +enterprise bindings diff --git a/extra/http/server/tags.txt b/extra/http/server/tags.txt index ebb39bcce3..b0881a9ec0 100644 --- a/extra/http/server/tags.txt +++ b/extra/http/server/tags.txt @@ -1,2 +1,3 @@ +enterprise network web diff --git a/extra/ldap/tags.txt b/extra/ldap/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/ldap/tags.txt +++ b/extra/ldap/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/openssl/tags.txt b/extra/openssl/tags.txt index 59ccdd65e6..93e252c19e 100644 --- a/extra/openssl/tags.txt +++ b/extra/openssl/tags.txt @@ -1,2 +1,3 @@ +enterprise network bindings diff --git a/extra/smtp/tags.txt b/extra/smtp/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/smtp/tags.txt +++ b/extra/smtp/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/xml-rpc/tags.txt b/extra/xml-rpc/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml-rpc/tags.txt +++ b/extra/xml-rpc/tags.txt @@ -1 +1,2 @@ +enterprise web diff --git a/extra/xml/tags.txt b/extra/xml/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml/tags.txt +++ b/extra/xml/tags.txt @@ -1 +1,2 @@ +enterprise web From fdac73a4d74a05306293fddebcd39142313b3887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:15:29 -0600 Subject: [PATCH 025/104] Oops --- extra/concurrency/concurrency.factor | 33 ++++++++++++++-------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index e4972c9030..b46439b583 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,12 +264,7 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future value processes ; - -: notify-future ( value future -- ) - tuck set-future-value - dup future-processes [ schedule-thread ] each - f swap set-future-processes ; +TUPLE: future status value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return @@ -277,22 +272,28 @@ TUPLE: future value processes ; #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - \ future construct-empty [ + [ [ - >r [ t 2array ] compose [ f 2array ] recover r> - notify-future - ] 2curry spawn drop - ] keep ; + t + ] compose + ] spawn drop + [ self send ] compose spawn ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - dup future-value [ - first2 [ throw ] unless - ] [ - dup [ future-processes push stop ] curry callcc0 ?future - ] ?if ; + process-mailbox mailbox-get ; + +: parallel-map ( seq quot -- newseq ) + #! Spawn a process to apply quot to each element of seq, + #! joining the results into a sequence at the end. + [ curry future ] curry map [ ?future ] map ; + +: parallel-each ( seq quot -- ) + #! Spawn a process to apply quot to each element of seq, + #! and waits for all processes to complete. + [ f ] compose parallel-map drop ; TUPLE: promise fulfilled? value processes ; From 122be5b48ec22a69dd1afd0d2f441aacb9e4ed97 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 9 Feb 2008 00:17:24 -0800 Subject: [PATCH 026/104] Added set-fullscreen? and fullscreen? hooks along with their cocoa implementations. --- extra/cocoa/cocoa.factor | 1 + extra/ui/backend/backend.factor | 4 ++++ extra/ui/cocoa/cocoa.factor | 14 +++++++++++++- extra/ui/gadgets/worlds/worlds-docs.factor | 9 +++++++++ 4 files changed, 27 insertions(+), 1 deletion(-) diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index cbc6c9d762..c94984f00b 100755 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -58,6 +58,7 @@ SYMBOL: super-sent-messages "NSPasteboard" "NSResponder" "NSSavePanel" + "NSScreen" "NSView" "NSWindow" "NSWorkspace" diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index a0646f35b0..cc1f5f7d05 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -7,6 +7,10 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) +HOOK: set-fullscreen? ui-backend ( ? world -- ) + +HOOK: fullscreen? ui-backend ( world -- ? ) + HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 1e46544180..184e6fd856 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cocoa cocoa.application command-line +USING: math arrays cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend @@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents M: cocoa-ui-backend set-title ( string world -- ) world-handle second swap -> setTitle: ; +: enter-fullscreen ( world -- ) + world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; + +: exit-fullscreen ( world -- ) + world-handle first f -> exitFullScreenModeWithOptions: ; + +M: cocoa-ui-backend set-fullscreen? ( ? world -- ) + swap [ enter-fullscreen ] [ exit-fullscreen ] if ; + +M: cocoa-ui-backend fullscreen? ( world -- ? ) + world-handle first -> isInFullScreenMode zero? not ; + : auto-position ( world -- ) dup world-loc { 0 0 } = [ world-handle second -> center diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index a47717329d..8a64750751 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,6 +13,15 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; +HELP: set-fullscreen? +{ $values { "?" "a boolean" } { "world" world } } +{ $description "Sets and unsets fullscreen mode for the world." } +{ $notes "Find a world using " { $link find-world } "." } ; + +HELP: fullscreen? +{ $values { "world" world } { "?" "a boolean" } } +{ $description "Queries the world to see if it is running in fullscreen mode." } ; + HELP: raise-window { $values { "world" world } } { $description "Makes the native window containing the given world the front-most window." } From 7fbbe94d80c473c94f5b11f558cda2f5977d78d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:19:26 -0600 Subject: [PATCH 027/104] FEP work in progress --- vm/debug.c | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/vm/debug.c b/vm/debug.c index 5b4320b5e9..01e1ab0f43 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting) CELL length = array_capacity(array); CELL i; + if(length > 10) + length = 10; + for(i = 0; i < length; i++) { printf(" "); @@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type) if(type == -1 || type_of(obj) == type) { printf("%lx ",obj); - print_nested_obj(obj,3); + print_nested_obj(obj,1); printf("\n"); } } @@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type) gc_off = false; } +CELL obj; +CELL look_for; + +void find_references_step(CELL *scan) +{ + if(look_for == *scan) + { + printf("%lx ",obj); + print_nested_obj(obj,1); + printf("\n"); + } +} + +void find_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + CELL obj_; + while((obj_ = next_object()) != F) + { + obj = obj_; + do_slots(obj_,find_references_step); + } + + /* end scan */ + gc_off = false; +} + void factorbug(void) { reset_stdio(); From e9a63d7a2c2d080e778a3f3e8bd4b99d2867588f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:10:52 -0600 Subject: [PATCH 028/104] Arrggh --- extra/concurrency/concurrency.factor | 34 ++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b46439b583..3c8011cc6b 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,26 +264,36 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future status value processes ; +TUPLE: future value processes ; +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return - #! a 'future' on the stack. The future can later be queried with - #! ?future. If the quotation has completed the result will be returned. - #! If not, the process will block until the quotation completes. - #! 'quot' must have stack effect ( -- X ). + #! Spawn a process to call the quotation and immediately return. + \ future construct-empty [ [ [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; t ] compose ] spawn drop [ self send ] compose spawn ; - -: ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. - process-mailbox mailbox-get ; + + : ?future ( future -- result ) + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; : parallel-map ( seq quot -- newseq ) #! Spawn a process to apply quot to each element of seq, From 3121e740f2838d6d29ef0e1291fd8da670bb2416 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:12:14 -0600 Subject: [PATCH 029/104] Fix typo --- core/continuations/continuations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2977d02c6f..7cf15394ef 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -169,7 +169,7 @@ HELP: rethrow HELP: throw-restarts { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." } +{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } { $examples "Try invoking one of the two restarts which are offered after the below code throws an error:" { $code From 25c64c8ac713cc94bf706124900f3658e3e34167 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:13:06 -0600 Subject: [PATCH 030/104] Arrghh!!! --- extra/concurrency/concurrency.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 3c8011cc6b..50abee8418 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -280,15 +280,11 @@ TUPLE: future value processes ; notify-future ] 2curry spawn drop ] keep ; - t - ] compose - ] spawn drop - [ self send ] compose spawn ; : ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. dup future-value [ first2 [ throw ] unless ] [ From a21781e3807d1c89cba88989cb694e65d81d0ee3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:14:37 -0600 Subject: [PATCH 031/104] Concurrency fix --- extra/concurrency/concurrency.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 50abee8418..a8e0bc6eeb 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -270,11 +270,10 @@ TUPLE: future value processes ; tuck set-future-value dup future-processes [ schedule-thread ] each f swap set-future-processes ; - + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. \ future construct-empty [ - [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future From 5ca99b0105c82b881ccb023fee8b502e5a2651ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:15 -0600 Subject: [PATCH 032/104] Fix 'class' in early bootstrap --- core/classes/classes.factor | 4 +++- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 151429bf69..345676e106 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -20,7 +20,9 @@ PREDICATE: class tuple-class : classes ( -- seq ) classclass ( n -- class ) builtins get nth ; +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8cf83b0ba7..21a7857646 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ; : math-vtable* ( picker max quot -- quot ) [ rot , \ tag , - [ >r [ type>class ] map r> map % ] { } make , + [ >r [ bootstrap-type>class ] map r> map % ] { } make , \ dispatch , ] [ ] make ; inline diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 88f6a05bc2..7f4f423d8b 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -97,7 +97,7 @@ TUPLE: no-method object generic ; [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) - type>class [ hi-tag bootstrap-word ] unless* ; + bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; : group-methods ( assoc -- vtable ) #! Input is a predicate -> method association. From ee912c5996e9342d921c51051cd71001d94b2048 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:40 -0600 Subject: [PATCH 033/104] Walker cleanup --- extra/ui/tools/walker/walker.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 4740ff86d4..a23345d214 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ; : walker-active? ( walker -- ? ) walker-interpreter interpreter-continuation >boolean ; -: walker-command ( gadget quot -- ) - over walker-active? [ with-walker ] [ 2drop ] if ; inline - : save-interpreter ( walker -- ) dup walker-interpreter interpreter-continuation clone swap walker-history push ; -: com-step ( walker -- ) - dup save-interpreter [ step ] walker-command ; +: walker-command ( gadget quot -- ) + over walker-active? [ + over save-interpreter + with-walker + ] [ 2drop ] if ; inline -: com-into ( walker -- ) - dup save-interpreter [ step-into ] walker-command ; +: com-step ( walker -- ) [ step ] walker-command ; -: com-out ( walker -- ) - dup save-interpreter [ step-out ] walker-command ; +: com-into ( walker -- ) [ step-into ] walker-command ; + +: com-out ( walker -- ) [ step-out ] walker-command ; : com-back ( walker -- ) dup walker-history From ef63333980d03f963bb50b076ec52c10923cbcff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 18:12:07 -0600 Subject: [PATCH 034/104] Fix another bug with futures --- extra/concurrency/concurrency-tests.factor | 5 +++++ extra/concurrency/concurrency.factor | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index 1a19ce7096..8908506d51 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -133,4 +133,9 @@ SYMBOL: value [ 3 3 ] [ [ 3 ] future dup ?future swap ?future +] unit-test + +! Another race +[ 3 ] [ + [ 3 yield ] future ?future ] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index a8e0bc6eeb..1c5f6322a8 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -273,14 +273,14 @@ TUPLE: future value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. - \ future construct-empty [ + f V{ } clone \ future construct-boa [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future ] 2curry spawn drop ] keep ; - - : ?future ( future -- result ) + +: ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. From f655a25762173982ee894d61f7ca755524127aa1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:08:47 -0600 Subject: [PATCH 035/104] Fixing compiler test --- core/bootstrap/compiler/compiler.factor | 11 +++++++++++ core/compiler/test/simple/simple-tests.factor | 4 +++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..2b278ac458 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -77,3 +77,14 @@ nl [ compiled-usages recompile ] recompile-hook set-global " done" print flush + +! Load empty test vocabs +USE: compiler.test.curry +USE: compiler.test.float +USE: compiler.test.intrinsics +USE: compiler.test.redefine +USE: compiler.test.simple +USE: compiler.test.stack-trace +USE: compiler.test.templates +USE: compiler.test.templates-early +USE: compiler.test.tuples diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor index 3f4f6451a3..743fb713d9 100755 --- a/core/compiler/test/simple/simple-tests.factor +++ b/core/compiler/test/simple/simple-tests.factor @@ -1,6 +1,6 @@ USING: compiler tools.test kernel kernel.private combinators.private math.private math combinators strings -alien arrays ; +alien arrays memory ; IN: temporary ! Test empty word @@ -48,6 +48,8 @@ IN: temporary [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test + ! Labels : recursive ( ? -- ) [ f recursive ] when ; inline From 93e10566bef56950add23087e64af1e3da3f2575 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:12:00 -0600 Subject: [PATCH 036/104] Simpler compilation of dispatch --- core/cpu/architecture/architecture.factor | 4 +- core/cpu/ppc/architecture/architecture.factor | 23 +++++------ core/cpu/x86/architecture/architecture.factor | 39 ++++++++++--------- core/generator/generator.factor | 29 +++++++++----- 4 files changed, 50 insertions(+), 45 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4da22ff38a..4bb10b23a2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- ) ! Test if vreg is 'f' or not HOOK: %jump-t compiler-backend ( label -- ) -HOOK: %call-dispatch compiler-backend ( -- label ) - -HOOK: %jump-dispatch compiler-backend ( -- ) +HOOK: %dispatch compiler-backend ( -- ) HOOK: %dispatch-label compiler-backend ( word -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 7444c21a8c..1daf3ac622 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ; M: ppc-backend %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -: (%dispatch) ( len -- ) - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here - "offset" operand "n" operand 1 SRAWI - 11 11 "offset" operand ADD - 11 dup rot cells LWZ ; - -M: ppc-backend %call-dispatch ( word-table# -- ) - [ 7 (%dispatch) (%call)