\ foo is now a first-class type; this removes the need for inference-level partial eval, and simplifies a lot of other code

CHANGES.html

@@ -25,17 +25,23 @@
 <b>"usr/bin/grep"</b></pre></li>
 <li>Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the <code>count ( n -- [ 0 ... n-1 ] )</code> word is gone; just use <code>&gt;vector</code> instead. Also, <code>project</code> has been made redundant by <code>map</code>.</li>
 <li>The <code>seq-transpose ( seq -- seq )</code> word is now named <code>flip</code>.
-</ul>
-
 </li>
 </ul>
 
-<ul>Everything else:
+</li>
+
+<li>Everything else:
+
+<ul>
 <li>Object slots are now clickable in the inspector</li>
 <li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
 <li>More descriptive "out of bounds" errors.</li>
 </ul>
 
+</li>
+
+</ul>
+
 <h1>Factor 0.76:</h1>
 
 <ul>

Makefile

@@ -54,7 +54,8 @@ OBJS = $(PLAF_OBJS) native/arithmetic.o native/array.o native/bignum.o \
 	native/debug.o \
 	native/hashtable.o \
 	native/icache.o \
-	native/io.o
+	native/io.o \
+	native/wrapper.o
 
 default:
 	@echo "Run 'make' with one of the following parameters:"

library/bootstrap/boot-stage1.factor

@@ -90,7 +90,6 @@ parser prettyprint sequences io vectors words ;
         "/library/inference/branches.factor"
         "/library/inference/words.factor"
         "/library/inference/stack.factor"
-        "/library/inference/partial-eval.factor"
         "/library/inference/class-infer.factor"
         "/library/inference/optimizer.factor"
         "/library/inference/inline-methods.factor"

library/bootstrap/boot-stage3.factor

@@ -67,7 +67,6 @@ t [
     "/library/tools/word-tools.factor"
     "/library/syntax/see.factor"
     "/library/test/test.factor"
-    "/library/inference/test.factor"
     "/library/tools/walker.factor"
     "/library/tools/annotations.factor"
     "/library/tools/inspector.factor"

library/bootstrap/image.factor

@@ -47,6 +47,7 @@ SYMBOL: boot-quot
 : hashtable-type 10 ; inline
 : vector-type    11 ; inline
 : string-type    12 ; inline
+: wrapper-type   14 ; inline
 : word-type      17 ; inline
 : tuple-type     18 ; inline
 
@@ -173,8 +174,15 @@ M: f ' ( obj -- ptr )
     image get [ dup word? [ fixup-word ] when ] nmap ;
 
 M: word ' ( word -- pointer )
-    transfer-word dup pooled-object
+    transfer-word dup pooled-object [ ] [ ] ?ifte ;
-    dup [ nip ] [ drop ] ifte ;
+
+( Wrappers )
+
+M: wrapper ' ( wrapper -- pointer )
+    wrapped '
+    object-tag here-as >r
+    wrapper-type >header emit
+    emit r> ;
 
 ( Conses )
 

library/bootstrap/primitives.factor

@@ -208,6 +208,7 @@ vocabularies get [
     { "fflush" "io-internals"                 [ [ alien ] [ ] ] }
     { "fclose" "io-internals"                 [ [ alien ] [ ] ] }
     { "expired?" "alien"                      [ [ object ] [ boolean ] ] }
+    { "<wrapper>" "kernel"                    [ [ object ] [ wrapper ] ] }
 } dup length 3 swap [ + ] map-with [
     make-primitive
 ] 2each

library/collections/namespaces.factor

@@ -1,8 +1,5 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: words
-DEFER: literalize
-
 IN: namespaces
 USING: hashtables kernel kernel-internals lists math sequences
 strings vectors words ;
@@ -120,11 +117,6 @@ SYMBOL: building
     #! Append to the sequence being built with make-seq.
     building get swap nappend ;
 
-: literal, ( word -- )
-    #! Append some code that pushes the word on the stack. Used
-    #! when building quotations.
-    literalize % ;
-
 : make-vector ( quot -- vector )
     100 <vector> make-seq ; inline
 

library/compiler/intrinsics.factor

@@ -185,7 +185,7 @@ sequences vectors words ;
     [[ fixnum>       %fixnum>       ]]
     [[ eq?           %eq?           ]]
 ] [
-    uncons [ literal, \ binary-op , ] make-list
+    uncons [ literalize , \ binary-op , ] make-list
     "intrinsic" set-word-prop
 ] each
 

library/generic/generic.factor

@@ -68,7 +68,7 @@ DEFER: delegate
 : dispatcher% "dispatcher" word-prop % ;
 
 : error-method ( generic -- method )
-    [ dup picker% literal, \ no-method , ] make-list ;
+    [ dup picker% literalize , \ no-method , ] make-list ;
 
 : empty-method ( generic -- method )
     dup "picker" word-prop [ dup ] = [

library/generic/tuple.factor

@@ -28,7 +28,7 @@ BUILTIN: tuple 18 tuple? ;
     #! Make a foo? word for testing the tuple class at the top
     #! of the stack.
     dup predicate-word
-    [ \ class , over literal, \ eq? , ] make-list
+    [ \ class , over literalize , \ eq? , ] make-list
     define-predicate ;
 
 : forget-tuple ( class -- )
@@ -54,7 +54,7 @@ BUILTIN: tuple 18 tuple? ;
 
 : define-constructor ( word def -- )
     >r [ word-name "in" get constructor-word ] keep [
-        dup literal, "tuple-size" word-prop , \ make-tuple ,
+        dup literalize , "tuple-size" word-prop , \ make-tuple ,
     ] make-list r> append define-compound ;
 
 : default-constructor ( tuple -- )
@@ -79,7 +79,7 @@ BUILTIN: tuple 18 tuple? ;
     [
         [
             unswons
-            \ dup , unswons literal, \ eq? , \ drop swons ,
+            \ dup , unswons literalize , \ eq? , \ drop swons ,
             alist>quot , \ ifte ,
         ] make-list
     ] when* ;

library/inference/inference.factor

@@ -58,6 +58,8 @@ GENERIC: apply-object
 
 M: object apply-object apply-literal ;
 
+M: wrapper apply-object wrapped apply-literal ;
+
 : active? ( -- ? )
     #! Is this branch not terminated?
     d-in get meta-d get and ;

library/inference/partial-eval.factor

@@ -1,97 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: errors generic interpreter kernel lists math namespaces
-sequences words ;
-
-: literal-inputs? ( in stack -- )
-    tail-slice* dup [ safe-literal? ] all?
-    [ length #drop node, t ] [ drop f ] ifte ;
-
-: literal-inputs ( out stack -- )
-    tail-slice* [ literal-value ] nmap ;
-
-: literal-outputs ( out stack -- )
-    tail-slice* dup [ recursive-state get <literal> ] nmap
-    length #push node, ;
-
-: partial-eval? ( word -- ? )
-    "infer-effect" word-prop car length
-    meta-d get literal-inputs? ;
-
-: infer-eval ( word -- )
-    dup partial-eval? [
-        dup "infer-effect" word-prop 2unlist
-        -rot length meta-d get
-        literal-inputs [
-            apply-datastack
-        ] [
-            [ "infer-effect" word-prop consume/produce ]
-            [ length meta-d get literal-outputs ] ifte
-        ] catch
-    ] [
-        dup "infer-effect" word-prop consume/produce
-    ] ifte ;
-
-: stateless ( word -- )
-    #! A stateless word can be evaluated at compile-time.
-    dup unit [ car infer-eval ] cons "infer" set-word-prop ;
-
-! Could probably add more words here
-[
-    eq?
-    car
-    cdr
-    cons
-    <
-    <=
-    >
-    >=
-    number=
-    +
-    -
-    *
-    /
-    /i
-    /f
-    mod
-    /mod
-    bitand
-    bitor
-    bitxor
-    shift
-    bitnot
-    >fixnum
-    >bignum
-    >float
-    real
-    imaginary
-] [
-    stateless
-] each
-
-! Partially-evaluated words need their stack effects to be
-! entered by hand.
-\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
-\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
-\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

library/inference/test.factor

@@ -1,26 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: test
-USING: errors inference kernel lists namespaces prettyprint
-io strings unparser ;
-
-: try-infer ( quot -- effect error )
-    [ infer f ] [ [ >r drop f r> ] when* ] catch ;
-
-: infer-fail ( quot error -- )
-    "! " , dup string? [ unparse ] unless , "\n" ,
-    [ [ infer ] cons . \ unit-test-fails . ] string-out % ;
-
-: infer-pass ( quot effect -- )
-    [ unit . [ infer ] cons . \ unit-test . ] string-out % ;
-
-: infer>test ( quot -- str )
-    #! Make a string representing a unit test for the stack
-    #! effect of a word.
-    [
-        dup try-infer [ infer-fail ] [ infer-pass ] ?ifte
-    ] make-string ;
-
-: infer>test. ( word -- )
-    #! Print a inference unit test for a word.
-    infer>test write ;

library/inference/words.factor

@@ -165,3 +165,25 @@ M: compound apply-object ( word -- )
 \ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
 \ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
 \ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
+\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
+\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
+\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
+\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
+\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
+\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

library/kernel.factor

@@ -27,6 +27,12 @@ M: object clone ;
     #! Push t if cond is true, otherwise push f.
     rot [ drop ] [ nip ] ifte ; inline
 
+DEFER: wrapper?
+BUILTIN: wrapper 14 wrapper? { 1 "wrapped" "set-wrapped" } ;
+
+M: wrapper = ( obj wrapper -- ? )
+    over wrapper? [ swap wrapped = ] [ 2drop f ] ifte ;
+
 ! defined in parse-syntax.factor
 DEFER: not
 DEFER: t?

library/syntax/parse-syntax.factor

@@ -73,7 +73,12 @@ BUILTIN: f 9 not ;
 : \
     #! Parsed as a piece of code that pushes a word on the stack
     #! \ foo ==> [ foo ] car
-    scan-word literalize [ swons ] each ; parsing
+    scan-word literalize swons ; parsing
+
+! Long wrapper syntax. Only used in the rare case that another
+! wrapper is being wrapped.
+: W[ [ ] ; parsing
+: ]W first <wrapper> swons ; parsing
 
 ! Vocabularies
 : PRIMITIVE:

library/syntax/prettyprint.factor

@@ -31,30 +31,6 @@ M: word prettyprint* ( indent word -- indent )
 : prettyprint-newline ( indent -- )
     "\n" write indent ;
 
-: \? ( list -- ? )
-    #! Is the head of the list a [ foo ] car?
-    dup car dup cons? [
-        dup car word? [
-            cdr [ drop f ] [ second \ car = ] ifte
-        ] [
-            2drop f
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-: prettyprint-elements ( indent list -- indent )
-    [
-        dup \? [
-            \ \ unparse. bl
-            uncons >r car unparse. bl
-            r> cdr prettyprint-elements
-        ] [
-            uncons >r prettyprint* bl
-            r> prettyprint-elements
-        ] ifte
-    ] when* ;
-
 : ?prettyprint-newline ( indent -- )
     one-line get [ bl drop ] [ prettyprint-newline ] ifte ;
 
@@ -79,6 +55,9 @@ M: word prettyprint* ( indent word -- indent )
         recursion-check [ cdr ] change
     ] ifte ; inline
 
+: prettyprint-elements ( indent list -- indent )
+    [ prettyprint* bl ] each ;
+
 : prettyprint-sequence ( indent start list end -- indent )
     #! Prettyprint a list, with start/end delimiters; eg, [ ],
     #! or { }, or << >>. The body of the list is indented,
@@ -102,7 +81,7 @@ M: cons prettyprint* ( indent list -- indent )
 
 M: vector prettyprint* ( indent vector -- indent )
     [
-        \ { swap >list \ } prettyprint-sequence
+        \ { swap \ } prettyprint-sequence
     ] check-recursion ;
 
 M: hashtable prettyprint* ( indent hashtable -- indent )
@@ -112,12 +91,19 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
 
 M: tuple prettyprint* ( indent tuple -- indent )
     [
-        \ << swap <mirror> >list \ >> prettyprint-sequence
+        \ << swap <mirror> \ >> prettyprint-sequence
     ] check-recursion ;
 
-M: alien prettyprint* ( alien -- str )
+M: alien prettyprint* ( alien -- )
     \ ALIEN: unparse. bl alien-address unparse write ;
 
+M: wrapper prettyprint* ( wrapper -- )
+    dup wrapped word? [
+        \ \ unparse. bl wrapped unparse.
+    ] [
+        \ W[ unparse. bl wrapped prettyprint* \ ]W unparse.
+    ] ifte ;
+
 : prettyprint ( obj -- )
     [
         recursion-check off

library/tools/interpreter.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: interpreter
-USING: errors kernel kernel-internals lists math namespaces
+USING: errors generic io kernel kernel-internals lists math
-prettyprint sequences io strings vectors words ;
+namespaces prettyprint sequences strings vectors words ;
 
 ! A Factor interpreter written in Factor. Used by compiler for
 ! partial evaluation, also by the walker.
@@ -14,8 +14,6 @@ SYMBOL: meta-r
 SYMBOL: meta-d
 : push-d meta-d get push ;
 : pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
-: peek-next-d meta-d get [ length 2 - ] keep nth ;
 SYMBOL: meta-n
 SYMBOL: meta-c
 
@@ -66,7 +64,9 @@ SYMBOL: meta-executing
         [ meta-executing get push-r  push-r ] when*
     ] change ;
 
-: meta-word ( word -- )
+GENERIC: do ( obj -- )
+
+M: word do ( word -- )
     dup "meta-word" word-prop [
         call
     ] [
@@ -77,12 +77,18 @@ SYMBOL: meta-executing
         ] ifte
     ] ?ifte ;
 
-: do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ;
+M: wrapper do ( wrapper -- ) wrapped push-d ;
 
-: meta-word-1 ( word -- )
+M: object do ( object -- ) push-d ;
+
+GENERIC: do-1 ( object -- )
+
+M: word do-1 ( word -- )
     dup "meta-word" word-prop [ call ] [ host-word ] ?ifte ;
 
-: do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ;
+M: wrapper do-1 ( wrapper -- ) wrapped push-d ;
+
+M: object do-1 ( object -- ) push-d ;
 
 : set-meta-word ( word quot -- ) "meta-word" set-word-prop ;
 
@@ -93,7 +99,7 @@ SYMBOL: meta-executing
 \ callstack [ meta-r get clone push-d ] set-meta-word
 \ set-callstack [ pop-d clone meta-r set ] set-meta-word
 \ call [ pop-d meta-call ] set-meta-word
-\ execute [ pop-d meta-word ] set-meta-word
+\ execute [ pop-d do ] set-meta-word
 \ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
 \ dispatch [ pop-d pop-d swap nth meta-call ] set-meta-word
 

library/ui/presentations.factor

@@ -15,7 +15,7 @@ global [ 100 <vector> commands set ] bind
     commands get [ first call ] subset-with ;
 
 : command-quot ( presented quot -- quot )
-    [ swap literal, % ] make-list
+    [ swap literalize , % ] make-list
     [ pane get pane-call drop ] cons ;
 
 : command-menu ( presented -- menu )

library/words.factor

@@ -122,6 +122,10 @@ M: compound definer drop \ : ;
     over f "dispatcher" set-word-prop
     (define-compound) ;
 
-: literalize ( word/obj -- quot )
+GENERIC: literalize ( obj -- obj )
-    #! Produce a quotation that pushes this object.
+
-    dup word? [ unit [ car ] ] [ f ] ifte cons ;
+M: object literalize ;
+
+M: word literalize <wrapper> ;
+
+M: wrapper literalize <wrapper> ;

native/factor.h

@@ -131,6 +131,7 @@ typedef unsigned char BYTE;
 #include "relocate.h"
 #include "alien.h"
 #include "dll.h"
+#include "wrapper.h"
 #include "debug.h"
 
 #endif /* __FACTOR_H__ */

native/gc.c

@@ -179,6 +179,9 @@ INLINE void collect_object(CELL scan)
 	case DISPLACED_ALIEN_TYPE:
 		collect_displaced_alien((DISPLACED_ALIEN*)scan);
 		break;
+	case WRAPPER_TYPE:
+		collect_wrapper((F_WRAPPER*)scan);
+		break;
 	}
 }
 

native/memory.c

@@ -81,6 +81,9 @@ CELL untagged_object_size(CELL pointer)
 	case DISPLACED_ALIEN_TYPE:
 		size = sizeof(DISPLACED_ALIEN);
 		break;
+	case WRAPPER_TYPE:
+		size = sizeof(F_WRAPPER);
+		break;
 	default:
 		critical_error("Cannot determine untagged_object_size",pointer);
 		size = -1;/* can't happen */

native/memory.h

@@ -69,6 +69,7 @@ CELL T;
 #define STRING_TYPE 12
 #define SBUF_TYPE 13
 #define DLL_TYPE 15
+#define WRAPPER_TYPE 14
 #define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define TUPLE_TYPE 18

native/primitives.c

@@ -172,7 +172,8 @@ void* primitives[] = {
 	primitive_fwrite,
 	primitive_fflush,
 	primitive_fclose,
-	primitive_expired
+	primitive_expired,
+	primitive_wrapper
 };
 
 CELL primitive_to_xt(CELL primitive)

native/relocate.c

@@ -32,6 +32,9 @@ void relocate_object(CELL relocating)
 	case DISPLACED_ALIEN_TYPE:
 		fixup_displaced_alien((DISPLACED_ALIEN*)relocating);
 		break;
+	case WRAPPER_TYPE:
+		fixup_wrapper((F_WRAPPER*)relocating);
+		break;
 	}
 }
 

native/run.c

@@ -50,10 +50,18 @@ void run(void)
 		next = get(callframe);
 		callframe = get(callframe + CELLS);
 
-		if(type_of(next) == WORD_TYPE)
+		switch(type_of(next))
+		{
+		case WORD_TYPE:
 			execute(untag_word_fast(next));
-		else
+			break;
+		case WRAPPER_TYPE:
+			dpush(untag_wrapper_fast(next)->object);
+			break;
+		default:
 			dpush(next);
+			break;
+		}
 	}
 }
 

native/wrapper.c

@@ -0,0 +1,22 @@
+#include "factor.h"
+
+void primitive_wrapper(void)
+{
+	F_WRAPPER* wrapper;
+
+	maybe_gc(sizeof(F_WRAPPER));
+
+	wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+	wrapper->object = dpeek();
+	drepl(tag_object(wrapper));
+}
+
+void fixup_wrapper(F_WRAPPER* wrapper)
+{
+	data_fixup(&wrapper->object);
+}
+
+void collect_wrapper(F_WRAPPER* wrapper)
+{
+	copy_handle(&wrapper->object);
+}

native/wrapper.h

@@ -0,0 +1,13 @@
+typedef struct {
+	CELL header;
+	CELL object;
+} F_WRAPPER;
+
+INLINE F_WRAPPER* untag_wrapper_fast(CELL tagged)
+{
+	return (F_WRAPPER*)UNTAG(tagged);
+}
+
+void primitive_wrapper(void);
+void fixup_wrapper(F_WRAPPER* wrapper);
+void collect_wrapper(F_WRAPPER* wrapper);