diff --git a/CHANGES.html b/CHANGES.html
index 140ab1214f..97cf1bab0b 100644
--- a/CHANGES.html
+++ b/CHANGES.html
@@ -25,17 +25,23 @@
"usr/bin/grep"
Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the count ( n -- [ 0 ... n-1 ] )
word is gone; just use >vector
instead. Also, project
has been made redundant by map
.
The seq-transpose ( seq -- seq )
word is now named flip
.
-
-
-Everything else:
+
+
+- Everything else:
+
+
- Object slots are now clickable in the inspector
- The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the
math
vocabulary.
- More descriptive "out of bounds" errors.
+
+
+
+
Factor 0.76:
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 ] ] }
+ { "" "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 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 ] 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 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 >list \ >> prettyprint-sequence
+ \ << swap \ >> 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 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 ;
+
+M: wrapper literalize ;
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);