From f65aa407e92cc9b30a08bda549647916cb93e3bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 4 Aug 2005 03:56:28 +0000
Subject: [PATCH] \ 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                          | 12 +++-
 Makefile                              |  3 +-
 library/bootstrap/boot-stage1.factor  |  1 -
 library/bootstrap/boot-stage3.factor  |  1 -
 library/bootstrap/image.factor        | 12 +++-
 library/bootstrap/primitives.factor   |  1 +
 library/collections/namespaces.factor |  8 ---
 library/compiler/intrinsics.factor    |  2 +-
 library/generic/generic.factor        |  2 +-
 library/generic/tuple.factor          |  6 +-
 library/inference/inference.factor    |  2 +
 library/inference/partial-eval.factor | 97 ---------------------------
 library/inference/test.factor         | 26 -------
 library/inference/words.factor        | 22 ++++++
 library/kernel.factor                 |  6 ++
 library/syntax/parse-syntax.factor    |  7 +-
 library/syntax/prettyprint.factor     | 40 ++++-------
 library/tools/interpreter.factor      | 24 ++++---
 library/ui/presentations.factor       |  2 +-
 library/words.factor                  | 10 ++-
 native/factor.h                       |  1 +
 native/gc.c                           |  3 +
 native/memory.c                       |  3 +
 native/memory.h                       |  1 +
 native/primitives.c                   |  3 +-
 native/relocate.c                     |  3 +
 native/run.c                          | 12 +++-
 native/wrapper.c                      | 22 ++++++
 native/wrapper.h                      | 13 ++++
 29 files changed, 157 insertions(+), 188 deletions(-)
 delete mode 100644 library/inference/partial-eval.factor
 delete mode 100644 library/inference/test.factor
 create mode 100644 native/wrapper.c
 create mode 100644 native/wrapper.h

diff --git a/CHANGES.html b/CHANGES.html
index 140ab1214f..97cf1bab0b 100644
--- a/CHANGES.html
+++ b/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>
diff --git a/Makefile b/Makefile
index 0fa0af9fb9..1685ac0e58 100644
--- a/Makefile
+++ b/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:"
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index 709364bf38..65e8270298 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/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"
diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor
index d7c5fb6efa..8e2294d53f 100644
--- a/library/bootstrap/boot-stage3.factor
+++ b/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"
diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor
index 401b10f91e..43d39b0c96 100644
--- a/library/bootstrap/image.factor
+++ b/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
-    dup [ nip ] [ drop ] ifte ;
+    transfer-word dup pooled-object [ ] [ ] ?ifte ;
+
+( Wrappers )
+
+M: wrapper ' ( wrapper -- pointer )
+    wrapped '
+    object-tag here-as >r
+    wrapper-type >header emit
+    emit r> ;
 
 ( Conses )
 
diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor
index 08f61b4286..b727ef266d 100644
--- a/library/bootstrap/primitives.factor
+++ b/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
diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor
index 9c8ef4888b..91055a4ec1 100644
--- a/library/collections/namespaces.factor
+++ b/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
 
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 56cecf237c..b524fc795a 100644
--- a/library/compiler/intrinsics.factor
+++ b/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
 
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index 368776add1..e1a0bc33b0 100644
--- a/library/generic/generic.factor
+++ b/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 ] = [
diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor
index bfc41e6372..b18751f9cf 100644
--- a/library/generic/tuple.factor
+++ b/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* ;
diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index 0e855095fa..8bec93d72d 100644
--- a/library/inference/inference.factor
+++ b/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 ;
diff --git a/library/inference/partial-eval.factor b/library/inference/partial-eval.factor
deleted file mode 100644
index 996bd96cb0..0000000000
--- a/library/inference/partial-eval.factor
+++ /dev/null
@@ -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
diff --git a/library/inference/test.factor b/library/inference/test.factor
deleted file mode 100644
index 252e424c6b..0000000000
--- a/library/inference/test.factor
+++ /dev/null
@@ -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 ;
diff --git a/library/inference/words.factor b/library/inference/words.factor
index caaae875bf..e781ce3366 100644
--- a/library/inference/words.factor
+++ b/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
diff --git a/library/kernel.factor b/library/kernel.factor
index 4649cdd7c0..88d6a14d58 100644
--- a/library/kernel.factor
+++ b/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?
diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor
index 335ab445ef..388130691e 100644
--- a/library/syntax/parse-syntax.factor
+++ b/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:
diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor
index ac0449c6f2..5c6a055b4d 100644
--- a/library/syntax/prettyprint.factor
+++ b/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
diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor
index 366442a6ea..6c1930af0a 100644
--- a/library/tools/interpreter.factor
+++ b/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
-prettyprint sequences io strings vectors words ;
+USING: errors generic io kernel kernel-internals lists math
+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
 
diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor
index 5f7a7cfed3..dee5c62fbc 100644
--- a/library/ui/presentations.factor
+++ b/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 )
diff --git a/library/words.factor b/library/words.factor
index 4d45b71a16..64a8e68f7d 100644
--- a/library/words.factor
+++ b/library/words.factor
@@ -122,6 +122,10 @@ M: compound definer drop \ : ;
     over f "dispatcher" set-word-prop
     (define-compound) ;
 
-: literalize ( word/obj -- quot )
-    #! Produce a quotation that pushes this object.
-    dup word? [ unit [ car ] ] [ f ] ifte cons ;
+GENERIC: literalize ( obj -- obj )
+
+M: object literalize ;
+
+M: word literalize <wrapper> ;
+
+M: wrapper literalize <wrapper> ;
diff --git a/native/factor.h b/native/factor.h
index 1f3b28ca61..1cb17b0b24 100644
--- a/native/factor.h
+++ b/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__ */
diff --git a/native/gc.c b/native/gc.c
index 891aceee05..9ea242973e 100644
--- a/native/gc.c
+++ b/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;
 	}
 }
 
diff --git a/native/memory.c b/native/memory.c
index 8f8eaecf26..6225c0e2c7 100644
--- a/native/memory.c
+++ b/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 */
diff --git a/native/memory.h b/native/memory.h
index c38534ac67..96425c0137 100644
--- a/native/memory.h
+++ b/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
diff --git a/native/primitives.c b/native/primitives.c
index 52d8b044d7..54e80aecb1 100644
--- a/native/primitives.c
+++ b/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)
diff --git a/native/relocate.c b/native/relocate.c
index 602524b592..99aaee3f65 100644
--- a/native/relocate.c
+++ b/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;
 	}
 }
 
diff --git a/native/run.c b/native/run.c
index 33d0bdde89..e5bb8e813c 100644
--- a/native/run.c
+++ b/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;
+		}
 	}
 }
 
diff --git a/native/wrapper.c b/native/wrapper.c
new file mode 100644
index 0000000000..ac96687d1b
--- /dev/null
+++ b/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);
+}
diff --git a/native/wrapper.h b/native/wrapper.h
new file mode 100644
index 0000000000..65ef343afa
--- /dev/null
+++ b/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);