type inference work, and smart-term-hook

diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor
index e40c7f23d1c0fba5b7bd656f5aff6f373e56ddc6..5e77df53fbb1967574233e2610cca47021d1e3fb 100644 (file)
--- a/library/bootstrap/init-stage2.factor
+++ b/library/bootstrap/init-stage2.factor
@@ -27,7 +27,6 @@
 
 IN: kernel
 USE: ansi
-USE: win32-console
 USE: alien
 USE: compiler
 USE: errors
@@ -60,15 +59,12 @@ USE: unparser
     ! -no-<flag> CLI switch
     t "user-init" set
     t "interactive" set
-    ! We don't want ANSI escape codes on Windows
-    os "unix" = "ansi" set
     t "compile" set
+    t "smart-terminal" set
 
     ! The first CLI arg is the image name.
     cli-args uncons parse-command-line "image" set
 
-    "ansi" get [ stdio [ <ansi-stream> ] change ] when
-
     os "win32" = "compile" get and [
         "kernel32" "kernel32.dll" "stdcall" add-library
         "user32"   "user32.dll"   "stdcall" add-library
@@ -78,8 +74,8 @@ USE: unparser
 
     "compile" get [ compile-all ] when
 
-    os "win32" = "compile" get and [ 
-        stdio [ <win32-console-stream> ] change 
+    "smart-terminal" get [
+        stdio smart-term-hook get change 
     ] when
 
     run-user-init ;

diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index f4e0c5abaf1902c5dff08f3285ac61632f1a6d15..bf6826765264db0ce3e16d447804cf94ae6d41f1 100644 (file)
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -162,13 +162,13 @@ SYMBOL: object
 : type-union ( list list -- list )
     append prune [ > ] sort ;
 
-: class\/ ( class class -- class )
+: class-or ( class class -- class )
     #! Return a class that both classes are subclasses of.
     swap builtin-supertypes
     swap builtin-supertypes
     type-union classes get hash [ object ] unless* ;
 
-: class/\ ( class class -- class )
+: class-and ( class class -- class )
     #! Return a class that is a subclass of both, or raise an
     #! error if this is impossible.
     over builtin-supertypes

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index 5992a3a15fa4f2f958e68a2e41146295ebb8b2e6..98dde2453de22df172acdb7d11dd3945d71758ed 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -54,14 +54,13 @@ USE: hashtables
     #! shorter, pad it with unknown results at the bottom.
     dup longest-vector swap [ dupd add-inputs nip ] map nip ;
 
-: unify-results ( obj obj -- obj )
+: unify-classes ( value value -- value )
+    value-class swap value-class class-or <computed> ;
+
+: unify-results ( value value -- value )
     #! Replace values with unknown result if they differ,
     #! otherwise retain them.
-    2dup = [
-        drop
-    ] [
-        value-class swap value-class class\/ <computed>
-    ] ifte ;
+    2dup = [ drop ] [ unify-classes ] ifte ;
 
 : unify-stacks ( list -- stack )
     #! Replace differing literals in stacks with unknown
@@ -125,7 +124,7 @@ USE: hashtables
     #! Set base case if inference didn't fail.
     [
         f infer-branch [
-            effect recursive-state get set-base
+            effect old-effect recursive-state get set-base
         ] bind
     ] [
         [ drop ] when

diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor
index 2cca33d7d3339e6036d0122d61f4c677f03ad648..4eead823c2b6438f76c15eaf8776faf75f09b6d0 100644 (file)
--- a/library/inference/dataflow.factor
+++ b/library/inference/dataflow.factor
@@ -95,7 +95,7 @@ SYMBOL: node-param
     meta-d get vector-tail* node-consume-d set ;
 
 : dataflow-inputs ( in node -- )
-    [ dup cons? [ length ] when 0 node-inputs ] bind ;
+    [ dup list? [ length ] when 0 node-inputs ] bind ;
 
 : node-outputs ( d-count r-count -- )
     #! Execute in the node's namespace.
@@ -103,7 +103,7 @@ SYMBOL: node-param
     meta-d get vector-tail* node-produce-d set ;
 
 : dataflow-outputs ( out node -- )
-    [ dup cons? [ length ] when 0 node-outputs ] bind ;
+    [ dup list? [ length ] when 0 node-outputs ] bind ;
 
 : get-dataflow ( -- IR )
     dataflow-graph get reverse ;

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index 350af524d991ab6261e2c08d77ca27f7096f5f7d..5f5289c3d1d1aa0486a29cad08a41e381567c3ac 100644 (file)
--- a/library/inference/inference.factor
+++ b/library/inference/inference.factor
@@ -44,7 +44,8 @@ USE: generic
 ! - infer - quotation with custom inference behavior; ifte uses
 ! this. Word is passed on the stack.
 
-! Amount of results we had to add to the datastack
+! Vector of results we had to add to the datastack. Ie, the
+! inputs.
 SYMBOL: d-in
 
 ! Recursive state. Alist maps words to hashmaps...
@@ -67,6 +68,7 @@ SYMBOL: save-effect
 GENERIC: literal-value ( value -- obj )
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class ( value -- class )
+GENERIC: value-class-and ( class value -- )
 
 TRAITS: computed
 C: computed ( class -- value )
@@ -80,6 +82,8 @@ M: computed value= ( literal value -- ? )
     2drop f ;
 M: computed value-class ( value -- class )
     [ \ value-class get ] bind ;
+M: computed value-class-and ( class value -- )
+    [ \ value-class [ class-and ] change ] bind ;
 
 TRAITS: literal
 C: literal ( obj rstate -- value )
@@ -90,10 +94,27 @@ M: literal value= ( literal value -- ? )
     literal-value = ;
 M: literal value-class ( value -- class )
     literal-value class ;
+M: literal value-class-and ( class value -- )
+    value-class class-and drop ;
 
 : value-recursion ( value -- rstate )
     [ recursive-state get ] bind ;
 
+: (ensure-types) ( typelist n stack -- )
+    pick [
+        3dup >r >r car r> r> vector-nth value-class-and
+        >r >r cdr r> succ r> (ensure-types)
+    ] [
+        3drop
+    ] ifte ;
+
+: ensure-types ( typelist stack -- )
+    dup vector-length pick length - dup 0 < [
+        swap >r neg tail 0 r>
+    ] [
+        swap
+    ] ifte (ensure-types) ;
+
 : required-inputs ( typelist stack -- values )
     >r dup length r> vector-length - dup 0 > [
         head [ <computed> ] map
@@ -105,17 +126,22 @@ M: literal value-class ( value -- class )
     >r list>vector dup r> vector-append ;
 
 : ensure-d ( typelist -- )
+    dup meta-d get ensure-types
     meta-d get required-inputs dup
     meta-d [ vector-prepend ] change
     d-in [ vector-prepend ] change ;
 
-: effect ( -- [ in | out ] )
+: effect ( -- [ in-types out-types ] )
     #! After inference is finished, collect information.
-    d-in get vector-length meta-d get vector-length cons ;
+    d-in get [ value-class ] vector-map vector>list
+    meta-d get [ value-class ] vector-map vector>list 2list ;
+
+: old-effect ( [ in-types out-types ] | [ in | out ] )
+    uncons car length >r length r> cons ;
 
 : <recursive-state> ( -- state )
     <namespace> [
-        base-case off  effect entry-effect set
+        base-case off  effect old-effect entry-effect set
     ] extend ;
 
 : init-inference ( recursive-state -- )
@@ -194,10 +220,3 @@ DEFER: apply-word
 : dataflow ( quot -- dataflow )
     #! Data flow of a quotation.
     [ (infer) get-dataflow ] with-scope ;
-
-: type-infer ( quot -- [ in-types out-types ] )
-    [
-        (infer)
-        d-in get [ value-class ] vector-map vector>list
-        meta-d get [ value-class ] vector-map vector>list 2list
-    ] with-scope ;

diff --git a/library/inference/words.factor b/library/inference/words.factor
index 7521986e12642e99dcd1cb4d01c8e16060737aa9..f5970a0c6c566d66f77ad9bb7f1d5a5c64eeb4e8 100644 (file)
--- a/library/inference/words.factor
+++ b/library/inference/words.factor
@@ -43,9 +43,10 @@ USE: prettyprint
     #! Take input parameters, execute quotation, take output
     #! parameters, add node. The quotation is called with the
     #! stack effect.
-    >r dup car dup cons? [ [ drop object ] project ] unless ensure-d >r dataflow, r> r> rot
+    >r dup car dup list? [ [ drop object ] project ] unless ensure-d
+    >r dataflow, r> r> rot
     [ pick car swap dataflow-inputs ] keep
-    pick 2slip cdr swap
+    pick 2slip cdr dup cons? [ car ] when swap
     dataflow-outputs ; inline
 
 : consume-d ( typelist -- )
@@ -56,7 +57,7 @@ USE: prettyprint
 
 : (consume/produce) ( param op effect -- )
     [
-        dup cdr cons? [
+        dup cdr list? [
             ( new style )
             unswons consume-d car produce-d
         ] [
@@ -65,18 +66,18 @@ USE: prettyprint
         ] ifte
     ] with-dataflow ;
 
-: consume/produce ( word [ in | out ] -- )
+: consume/produce ( word [ in-types out-types ] -- )
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
     #call swap (consume/produce) ;
 
-: apply-effect ( word [ in | out ] -- )
+: apply-effect ( word [ in-types out-types ] -- )
     #! If a word does not have special inference behavior, we
     #! either execute the word in the meta interpreter (if it is
     #! side-effect-free and all parameters are literal), or
     #! simply apply its stack effect to the meta-interpreter.
     over "infer" word-property dup [
-        swap car dup cons? [ [ drop object ] project ] unless ensure-d call drop
+        swap car dup list? [ [ drop object ] project ] unless ensure-d call drop
     ] [
         drop consume/produce
     ] ifte ;

diff --git a/library/io/ansi.factor b/library/io/ansi.factor
index 7e37e1f83203b27c464f6d84ebf7700951901b1e..456636e5a4d91dd09033018348faafdb41cfa2b2 100644 (file)
--- a/library/io/ansi.factor
+++ b/library/io/ansi.factor
@@ -90,3 +90,5 @@ C: ansi-stream ( stream -- stream )
     #! ansi-fg - foreground color
     #! ansi-bg - background color
     [ delegate set ] extend ;
+
+global [ [ <ansi-stream> ] smart-term-hook set ] bind

diff --git a/library/io/stdio.factor b/library/io/stdio.factor
index d2f5bb3e501a0850636f2846d721b891502a9330..6654ae77eedd14da7f96828f671196ec3051978f 100644 (file)
--- a/library/io/stdio.factor
+++ b/library/io/stdio.factor
@@ -70,3 +70,6 @@ M: stdio-stream fclose ( -- )
 
 C: stdio-stream ( delegate -- stream )
     [ delegate set ] extend ;
+
+! Set this to a quotation in init code, depending on OS.
+SYMBOL: smart-term-hook

diff --git a/library/test/crashes.factor b/library/test/crashes.factor
index 26620bbb3d5bc06b53e7f1b10581514cdd9217de..c6a280851e2275808ae5f8987e2084842f73249b 100644 (file)
--- a/library/test/crashes.factor
+++ b/library/test/crashes.factor
@@ -8,6 +8,7 @@ USE: strings
 USE: test
 USE: vectors
 USE: lists
+USE: words
 
 ! Various things that broke CFactor at various times.
 ! This should run without issue (and tests nothing useful)
@@ -56,3 +57,8 @@ USE: lists
 [ callstack-overflow ] unit-test-fails
 
 [ [ cdr cons ] word-plist ] unit-test-fails
+
+! Forgot to tag out of bounds index
+[ 1 { } vector-nth ] [ garbage-collection drop ] catch
+[ -1 { } set-vector-length ] [ garbage-collection drop ] catch
+[ 1 "" str-nth ] [ garbage-collection drop ] catch

diff --git a/library/test/generic.factor b/library/test/generic.factor
index 3c575b5307d801be14fbda1955d1b86d816eb63e..d84b8659fe8f8e80bd2caafc9d55ad93145dc9ef 100644 (file)
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -126,13 +126,13 @@ M: very-funny gooey sq ;
 
 [ 1/4 ] [ 1/2 gooey ] unit-test
 
-[ object ] [ object object class/\ ] unit-test
-[ fixnum ] [ fixnum object class/\ ] unit-test
-[ fixnum ] [ object fixnum class/\ ] unit-test
-[ fixnum ] [ fixnum fixnum class/\ ] unit-test
-[ fixnum ] [ fixnum integer class/\ ] unit-test
-[ fixnum ] [ integer fixnum class/\ ] unit-test
-[ vector fixnum class/\ ] unit-test-fails
-[ integer ] [ fixnum bignum class\/ ] unit-test
-[ integer ] [ fixnum integer class\/ ] unit-test
-[ rational ] [ ratio integer class\/ ] unit-test
+[ object ] [ object object class-and ] unit-test
+[ fixnum ] [ fixnum object class-and ] unit-test
+[ fixnum ] [ object fixnum class-and ] unit-test
+[ fixnum ] [ fixnum fixnum class-and ] unit-test
+[ fixnum ] [ fixnum integer class-and ] unit-test
+[ fixnum ] [ integer fixnum class-and ] unit-test
+[ vector fixnum class-and ] unit-test-fails
+[ integer ] [ fixnum bignum class-or ] unit-test
+[ integer ] [ fixnum integer class-or ] unit-test
+[ rational ] [ ratio integer class-or ] unit-test

diff --git a/library/test/inference.factor b/library/test/inference.factor
index 27a5c80ffbe357a2b8d46feff70e4d9e3b832380..b6c059c5fea3b3c4fed1a3647b4af2e490a6b1db 100644 (file)
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -35,21 +35,21 @@ USE: generic
     5 f <literal> 6 f <literal> unify-results value-class
 ] unit-test
 
-[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer ] unit-test
-[ [ 1 | 2 ] ] [ [ dup ] infer ] unit-test
+[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer old-effect ] unit-test
+[ [ 1 | 2 ] ] [ [ dup ] infer old-effect ] unit-test
 
-[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer ] unit-test
-[ [ call ] infer ] unit-test-fails
+[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer old-effect ] unit-test
+[ [ call ] infer old-effect ] unit-test-fails
 
-[ [ 2 | 4 ] ] [ [ 2dup ] infer ] unit-test
-[ [ 2 | 0 ] ] [ [ set-vector-length ] infer ] unit-test
-[ [ 2 | 0 ] ] [ [ vector-push ] infer ] unit-test
+[ [ 2 | 4 ] ] [ [ 2dup ] infer old-effect ] unit-test
+[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test
+[ [ 2 | 0 ] ] [ [ vector-push ] infer old-effect ] unit-test
 
-[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test
-[ [ ifte ] infer ] unit-test-fails
-[ [ [ ] ifte ] infer ] unit-test-fails
-[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails
-[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test
+[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test
+[ [ ifte ] infer old-effect ] unit-test-fails
+[ [ [ ] ifte ] infer old-effect ] unit-test-fails
+[ [ [ 2 ] [ ] ifte ] infer old-effect ] unit-test-fails
+[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer old-effect ] unit-test
 
 [ [ 4 | 3 ] ] [
     [
@@ -58,18 +58,18 @@ USE: generic
         ] [
             -rot
         ] ifte
-    ] infer
+    ] infer old-effect
 ] unit-test
 
-[ [ 1 | 1 ] ] [ [ dup [ ] when ] infer ] unit-test
-[ [ 1 | 1 ] ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ [ dup fixnum* ] when ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ dup [ ] when ] infer old-effect ] unit-test
+[ [ 1 | 1 ] ] [ [ dup [ dup fixnum* ] when ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ [ dup fixnum* ] when ] infer old-effect ] unit-test
 
-[ [ 1 | 0 ] ] [ [ [ drop ] when* ] infer ] unit-test
-[ [ 1 | 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
+[ [ 1 | 0 ] ] [ [ [ drop ] when* ] infer old-effect ] unit-test
+[ [ 1 | 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer old-effect ] unit-test
 
 [ [ 0 | 1 ] ] [
-    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer
+    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer old-effect
 ] unit-test
 
 [
@@ -78,30 +78,30 @@ USE: generic
 
 : infinite-loop infinite-loop ;
 
-[ [ infinite-loop ] infer ] unit-test-fails
+[ [ infinite-loop ] infer old-effect ] unit-test-fails
 
 : simple-recursion-1
     dup [ simple-recursion-1 ] [ ] ifte ;
 
-[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer old-effect ] unit-test
 
 : simple-recursion-2
     dup [ ] [ simple-recursion-2 ] ifte ;
 
-[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer ] unit-test
+[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test
 
 : bad-recursion-1
     dup [ drop bad-recursion-1 5 ] [ ] ifte ;
 
-[ [ bad-recursion-1 ] infer ] unit-test-fails
+[ [ bad-recursion-1 ] infer old-effect ] unit-test-fails
 
 : bad-recursion-2
     dup [ uncons bad-recursion-2 ] [ ] ifte ;
 
-[ [ bad-recursion-2 ] infer ] unit-test-fails
+[ [ bad-recursion-2 ] infer old-effect ] unit-test-fails
 
 ! Simple combinators
-[ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer ] unit-test
+[ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test
 
 ! Mutual recursion
 DEFER: foe
@@ -126,7 +126,7 @@ DEFER: foe
 
 ! This form should not have a stack effect
 : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
-[ [ bad-bin ] infer ] unit-test-fails
+[ [ bad-bin ] infer old-effect ] unit-test-fails
 
 : nested-when ( -- )
     t [
@@ -135,7 +135,7 @@ DEFER: foe
         ] when
     ] when ;
 
-[ [ 0 | 0 ] ] [ [ nested-when ] infer ] unit-test
+[ [ 0 | 0 ] ] [ [ nested-when ] infer old-effect ] unit-test
 
 : nested-when* ( -- )
     [
@@ -144,60 +144,60 @@ DEFER: foe
         ] when*
     ] when* ;
 
-[ [ 1 | 0 ] ] [ [ nested-when* ] infer ] unit-test
+[ [ 1 | 0 ] ] [ [ nested-when* ] infer old-effect ] unit-test
 
 SYMBOL: sym-test
 
-[ [ 0 | 1 ] ] [ [ sym-test ] infer ] unit-test
-
-[ [ 2 | 1 ] ] [ [ fie ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ foe ] infer ] unit-test
-
-[ [ 2 | 1 ] ] [ [ 2list ] infer ] unit-test
-[ [ 3 | 1 ] ] [ [ 3list ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ append ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ swons ] infer ] unit-test
-[ [ 1 | 2 ] ] [ [ uncons ] infer ] unit-test
-[ [ 1 | 1 ] ] [ [ unit ] infer ] unit-test
-[ [ 1 | 2 ] ] [ [ unswons ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
-
-[ [ 1 | 1 ] ] [ [ length ] infer ] unit-test
-[ [ 1 | 1 ] ] [ [ reverse ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ contains? ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ tree-contains? ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ remove ] infer ] unit-test
-! [ [ 1 | 1 ] ] [ [ prune ] infer ] unit-test
-
-[ [ 2 | 1 ] ] [ [ bitor ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ bitand ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ bitxor ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ mod ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ /i ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ /f ] infer ] unit-test
-[ [ 2 | 2 ] ] [ [ /mod ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ + ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ - ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ * ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ / ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ < ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ <= ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ > ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ >= ] infer ] unit-test
-[ [ 2 | 1 ] ] [ [ number= ] infer ] unit-test
-
-[ [ 2 | 1 ] ] [ [ = ] infer ] unit-test
-
-[ [ 1 | 0 ] ] [ [ >n ] infer ] unit-test
-[ [ 0 | 1 ] ] [ [ n> ] infer ] unit-test
-
-[ [ 1 | 1 ] ] [ [ get ] infer ] unit-test
-
-! Type inference.
-
-[ [ [ object ] [ ] ] ] [ [ drop ] type-infer ] unit-test
-[ [ [ object ] [ object object ] ] ] [ [ dup ] type-infer ] unit-test
-[ [ [ object object ] [ cons ] ] ] [ [ cons ] type-infer ] unit-test
-[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] type-infer ] unit-test
+[ [ 0 | 1 ] ] [ [ sym-test ] infer old-effect ] unit-test
+
+[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
+
+[ [ 2 | 1 ] ] [ [ 2list ] infer old-effect ] unit-test
+[ [ 3 | 1 ] ] [ [ 3list ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ append ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ swons ] infer old-effect ] unit-test
+[ [ 1 | 2 ] ] [ [ uncons ] infer old-effect ] unit-test
+[ [ 1 | 1 ] ] [ [ unit ] infer old-effect ] unit-test
+[ [ 1 | 2 ] ] [ [ unswons ] infer old-effect ] unit-test
+! [ [ 1 | 1 ] ] [ [ last* ] infer old-effect ] unit-test
+! [ [ 1 | 1 ] ] [ [ last ] infer old-effect ] unit-test
+! [ [ 1 | 1 ] ] [ [ list? ] infer old-effect ] unit-test
+
+[ [ 1 | 1 ] ] [ [ length ] infer old-effect ] unit-test
+[ [ 1 | 1 ] ] [ [ reverse ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ contains? ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ tree-contains? ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ remove ] infer old-effect ] unit-test
+! [ [ 1 | 1 ] ] [ [ prune ] infer old-effect ] unit-test
+
+[ [ 2 | 1 ] ] [ [ bitor ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ bitand ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ bitxor ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ mod ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ /i ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ /f ] infer old-effect ] unit-test
+[ [ 2 | 2 ] ] [ [ /mod ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ + ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ - ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ * ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ / ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ < ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ <= ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ > ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ >= ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ number= ] infer old-effect ] unit-test
+
+[ [ 2 | 1 ] ] [ [ = ] infer old-effect ] unit-test
+
+[ [ 1 | 0 ] ] [ [ >n ] infer old-effect ] unit-test
+[ [ 0 | 1 ] ] [ [ n> ] infer old-effect ] unit-test
+
+[ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test
+
+! Type inference
+
+[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test

diff --git a/native/sbuf.c b/native/sbuf.c
index 121c6568efaa5df87b547486be03de19868fab50..7881829f3aca51b9e0193a5ff5f254961773bf8e 100644 (file)
--- a/native/sbuf.c
+++ b/native/sbuf.c
@@ -43,7 +43,7 @@ void primitive_sbuf_nth(void)
        CELL index = to_fixnum(dpop());
 
        if(index < 0 || index >= sbuf->top)
-               range_error(tag_object(sbuf),0,to_fixnum(index),sbuf->top);
+               range_error(tag_object(sbuf),0,tag_fixnum(index),sbuf->top);
        dpush(string_nth(untag_string(sbuf->string),index));
 }
 
@@ -59,7 +59,7 @@ void sbuf_ensure_capacity(F_SBUF* sbuf, F_FIXNUM top)
 void set_sbuf_nth(F_SBUF* sbuf, CELL index, uint16_t value)
 {
        if(index < 0)
-               range_error(tag_object(sbuf),0,to_fixnum(index),sbuf->top);
+               range_error(tag_object(sbuf),0,tag_fixnum(index),sbuf->top);
        else if(index >= sbuf->top)
                sbuf_ensure_capacity(sbuf,index + 1);
 

diff --git a/native/string.c b/native/string.c
index 9dbeeeb49c3490010f17333829e48ac4174e1e3f..b8884068145e2eb6fa87894ef169fffb83650adb 100644 (file)
--- a/native/string.c
+++ b/native/string.c
@@ -150,7 +150,7 @@ void primitive_string_nth(void)
        CELL index = to_fixnum(dpop());
 
        if(index < 0 || index >= string->capacity)
-               range_error(tag_object(string),0,to_fixnum(index),string->capacity);
+               range_error(tag_object(string),0,tag_fixnum(index),string->capacity);
        dpush(tag_fixnum(string_nth(string,index)));
 }
 
@@ -271,7 +271,7 @@ void primitive_index_of(void)
        index = to_fixnum(dpop());
        if(index < 0 || index > string->capacity)
        {
-               range_error(tag_object(string),0,to_fixnum(index),string->capacity);
+               range_error(tag_object(string),0,tag_fixnum(index),string->capacity);
                result = -1; /* can't happen */
        }
        else if(TAG(ch) == FIXNUM_TYPE)

diff --git a/native/vector.c b/native/vector.c
index edb4529a69975d9cb377a545b90ea10e9369c0d2..a805036146fd559a595a56c97f3dd6dc1a08a6c0 100644 (file)
--- a/native/vector.c
+++ b/native/vector.c
@@ -32,7 +32,7 @@ void primitive_set_vector_length(void)
        array = untag_array(vector->array);
 
        if(length < 0)
-               range_error(tag_object(vector),0,to_fixnum(length),vector->top);
+               range_error(tag_object(vector),0,tag_fixnum(length),vector->top);
        vector->top = length;
        if(length > array->capacity)
                vector->array = tag_object(grow_array(array,length,F));
@@ -44,7 +44,7 @@ void primitive_vector_nth(void)
        CELL index = to_fixnum(dpop());
 
        if(index < 0 || index >= vector->top)
-               range_error(tag_object(vector),0,to_fixnum(index),vector->top);
+               range_error(tag_object(vector),0,tag_fixnum(index),vector->top);
        dpush(array_nth(untag_array(vector->array),index));
 }
 
@@ -71,7 +71,7 @@ void primitive_set_vector_nth(void)
        value = dpop();
 
        if(index < 0)
-               range_error(tag_object(vector),0,to_fixnum(index),vector->top);
+               range_error(tag_object(vector),0,tag_fixnum(index),vector->top);
        else if(index >= vector->top)
                vector_ensure_capacity(vector,index);