steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Last traces of conses removed

slava 2006-05-17 18:55:46 +00:00
parent 9b286735ea
commit ee75b478ab
31 changed files with 186 additions and 243 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -54,7 +54,7 @@ endif
OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \
native/s48_bignum.o \
native/complex.o native/cons.o native/error.o \
native/complex.o native/error.o \
native/factor.o native/fixnum.o \
native/float.o native/gc.o \
native/image.o native/memory.o \

3
TODO.FACTOR.txt
View File

@ -1,5 +1,4 @@
should fix in 0.82:
- method ordering and interpreter algorithm sections need updates
- another i/o bug: on factorcode eventually all i/o times out
- get factor running on mac intel

30
doc/handbook/dataflow.facts
View File

@ -1,4 +1,4 @@
USING: errors help kernel lists namespaces threads words ;
USING: errors help kernel namespaces threads words ;
GLOSSARY: "stack" "see datastack" ;
@ -50,20 +50,20 @@ GLOSSARY: "combinator" "a word taking quotations or other words as input" ;
ARTICLE: "quotations" "Quotations and combinators"
"An evaluator executes quotations. Quotations are lists, and since lists can contain any Factor object, they can contain words. It is words that give quotations their operational behavior, as you can see in the following description of the evaluator algorithm."
{ $list
{ "If the callframe is " { $link f } ", the callstack is popped and becomes the new call frame." }
{ "If the " { $link car } " of the callframe is a word, the word is executed:"
{ $list
{ "If the word is a symbol, it is pushed on the datastack. See " { $link "symbols" } }
{ "If the word is a compound definition, the current callframe is pushed on the callstack, and the new callframe becomes the word definition. See " { $link "colon-definition" } }
{ "If the word is compiled or primitive, the interpreter jumps to a machine code definition. See " { $link "primitives" } }
{ "If the word is undefined, an error is raised. See " { $link "deferred" } }
}
}
{ "If the " { $link car } " of the callframe is a wrapper, the wrapped object is pushed on the datastack. Wrappers arise from the " { $link POSTPONE: \ } " parsing word." }
{ "Otherwise, the " { $link car } " of the call frame is pushed on the datastack." }
{ "The callframe is set to the " { $link cdr } ", and the loop continues." }
}
! { $list
! { "If the callframe is " { $link f } ", the callstack is popped and becomes the new call frame." }
! { "If the " { $link car } " of the callframe is a word, the word is executed:"
! { $list
! { "If the word is a symbol, it is pushed on the datastack. See " { $link "symbols" } }
! { "If the word is a compound definition, the current callframe is pushed on the callstack, and the new callframe becomes the word definition. See " { $link "colon-definition" } }
! { "If the word is compiled or primitive, the interpreter jumps to a machine code definition. See " { $link "primitives" } }
! { "If the word is undefined, an error is raised. See " { $link "deferred" } }
! }
! }
! { "If the " { $link car } " of the callframe is a wrapper, the wrapped object is pushed on the datastack. Wrappers arise from the " { $link POSTPONE: \ } " parsing word." }
! { "Otherwise, the " { $link car } " of the call frame is pushed on the datastack." }
! { "The callframe is set to the " { $link cdr } ", and the loop continues." }
! }
"The interpreter performs the above steps literally. The compiler generates machine code which perform the steps in a more efficient manner than the interpreter."
$terpri
"The following pair of words are central. They invoke the evaluator reflectively, allowing higher-order programming and meta-programming techniques that lie at the heart of Factor's expressive power."

2
doc/handbook/objects.facts
View File

@ -1,4 +1,4 @@
USING: generic help kernel lists sequences ;
USING: generic help kernel sequences ;
GLOSSARY: "object" "a datum which may appear on the stack" ;
ARTICLE: "objects" "Objects"

7
library/bootstrap/image.factor
View File

@ -10,7 +10,7 @@
! format.
USING: alien arrays errors generic hashtables
hashtables-internals help io kernel kernel-internals lists math
hashtables-internals help io kernel kernel-internals math
namespaces parser prettyprint sequences sequences-internals
strings vectors words ;
IN: image
@ -257,10 +257,7 @@ M: tuple ' ( tuple -- pointer )
M: array ' ( array -- pointer )
array-type emit-array ;
! M: quotation ' ( array -- pointer )
! quotation-type emit-array ;
M: cons ' ( c -- tagged )
M: quotation ' ( array -- pointer )
objects get [ quotation-type emit-array ] cache ;
M: vector ' ( vector -- pointer )

10
library/bootstrap/primitives.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: image
USING: alien arrays generic hashtables help io kernel
kernel-internals lists math namespaces parser sequences strings
kernel-internals math namespaces parser sequences strings
vectors words ;
! Some very tricky code creating a bootstrap embryo in the
@ -44,7 +44,6 @@ call
{ "call" "kernel" }
{ "if" "kernel" }
{ "dispatch" "kernel-internals" }
{ "cons" "lists" }
{ "<vector>" "vectors" }
{ "rehash-string" "strings" }
{ "<sbuf>" "strings" }
@ -268,13 +267,6 @@ num-types f <array> builtins set
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
"cons?" "lists" create t "inline" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
{
{ 0 object { "car" "lists" } f }
{ 1 object { "cdr" "lists" } f }
} define-builtin
"ratio?" "math" create t "inline" set-word-prop
"ratio" "math" create 4 "ratio?" "math" create
{

2
library/collections/arrays.facts
View File

@ -1,5 +1,5 @@
IN: arrays
USING: help kernel kernel-internals lists prettyprint strings
USING: help kernel kernel-internals prettyprint strings
vectors ;
HELP: <array> "( n elt -- array )"

27
library/collections/sequence-combinators.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005 Slava Pestov.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: sequences-internals
USING: arrays generic kernel kernel-internals math sequences
@ -39,13 +39,10 @@ vectors ;
IN: sequences
G: each ( seq quot -- | quot: elt -- )
1 standard-combination ; inline
M: object each ( seq quot -- )
: each ( seq quot -- | quot: elt -- )
swap dup length [
[ swap nth-unsafe swap call ] 3keep
] repeat 2drop ;
] repeat 2drop ; inline
: each-with ( obj seq quot -- | quot: obj elt -- )
swap [ with ] each 2drop ; inline
@ -53,16 +50,9 @@ M: object each ( seq quot -- )
: reduce ( seq identity quot -- value | quot: x y -- z )
swapd each ; inline
G: find ( seq quot -- i elt | quot: elt -- ? )
1 standard-combination ; inline
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
swap [ with rot ] find 2swap 2drop ; inline
G: map 1 standard-combination ; inline
M: object map ( seq quot -- seq )
: map ( seq quot -- seq | quot: elt -- elt )
swap [ dup length [ (map) ] collect ] keep like 2nip ;
inline
: map-with ( obj list quot -- list | quot: obj elt -- elt )
swap [ with rot ] map 2nip ; inline
@ -110,8 +100,11 @@ M: object map ( seq quot -- seq )
: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
-rot [ with rot ] find* 2swap 2drop ; inline
M: object find ( seq quot -- i elt )
0 -rot find* ;
: find ( seq quot -- i elt | quot: elt -- ? )
0 -rot find* ; inline
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
swap [ with rot ] find 2swap 2drop ; inline
: find-last* ( i seq quot -- i elt )
[

2
library/collections/sequence-eq.factor
View File

@ -4,7 +4,7 @@ IN: sequences
USING: arrays kernel math sequences-internals strings
vectors ;
UNION: sequence array string sbuf vector ;
UNION: sequence array string sbuf vector quotation ;
: sequence= ( seq seq -- ? )
2dup [ length ] 2apply = [

5
library/collections/sequences.factor
View File

@ -47,6 +47,11 @@ M: object set-nth-unsafe set-nth ;
pick pick >r >r >r swap nth-unsafe
r> call r> r> swap set-nth-unsafe ; inline
! The f object supports the sequence protocol trivially
M: f length drop 0 ;
M: f nth nip ;
M: f nth-unsafe nip ;
! Integers support the sequence protocol
M: integer length ;
M: integer nth drop ;

2
library/collections/strings.facts
View File

@ -1,4 +1,4 @@
USING: arrays help kernel lists strings vectors ;
USING: arrays help kernel strings vectors ;
HELP: <string> "( n ch -- string )"
{ $values { "n" "a positive integer specifying string length" } { "elt" "an initial character" } }

6
library/compiler/inference/known-words.factor
View File

@ -1,7 +1,7 @@
IN: inference
USING: arrays alien assembler errors generic hashtables
hashtables-internals interpreter io io-internals kernel
kernel-internals lists math math-internals memory parser
kernel-internals math math-internals memory parser
sequences strings vectors words prettyprint ;
\ declare [
@ -73,10 +73,6 @@ sequences strings vectors words prettyprint ;
] "infer" set-word-prop
! Stack effects for all primitives
\ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop
\ cons t "foldable" set-word-prop
\ cons t "flushable" set-word-prop
\ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
\ <vector> t "flushable" set-word-prop

2
library/syntax/prettyprint.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
USING: alien arrays generic hashtables io kernel lists math
USING: alien arrays generic hashtables io kernel math
namespaces parser sequences strings styles vectors words ;
! State

1
native/array.h
View File

@ -43,6 +43,7 @@ void primitive_array_to_tuple(void);
void primitive_tuple_to_array(void);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_capacity(F_ARRAY* array)
{

18
native/cons.c
View File

@ -1,18 +0,0 @@
#include "factor.h"
CELL cons(CELL car, CELL cdr)
{
F_CONS* cons = allot(sizeof(F_CONS));
cons->car = car;
cons->cdr = cdr;
return tag_cons(cons);
}
void primitive_cons(void)
{
CELL car, cdr;
maybe_gc(sizeof(F_CONS));
cdr = dpop();
car = dpop();
dpush(cons(car,cdr));
}

19
native/cons.h
View File

@ -1,19 +0,0 @@
typedef struct {
CELL car;
CELL cdr;
} F_CONS;
INLINE F_CONS* untag_cons(CELL tagged)
{
type_check(CONS_TYPE,tagged);
return (F_CONS*)UNTAG(tagged);
}
INLINE CELL tag_cons(F_CONS* cons)
{
return RETAG(cons,CONS_TYPE);
}
CELL cons(CELL car, CELL cdr);
void primitive_cons(void);

27
native/debug.c
View File

@ -1,26 +1,5 @@
#include "factor.h"
void print_cons(CELL cons)
{
fprintf(stderr,"[ ");
do
{
print_obj(untag_cons(cons)->car);
fprintf(stderr," ");
cons = untag_cons(cons)->cdr;
}
while(TAG(cons) == CONS_TYPE);
if(cons != F)
{
fprintf(stderr,"| ");
print_obj(cons);
fprintf(stderr," ");
}
fprintf(stderr,"]");
}
void print_word(F_WORD* word)
{
if(type_of(word->name) == STRING_TYPE)
@ -61,9 +40,6 @@ void print_obj(CELL obj)
case FIXNUM_TYPE:
fprintf(stderr,"%ld",untag_fixnum_fast(obj));
break;
case CONS_TYPE:
print_cons(obj);
break;
case WORD_TYPE:
print_word(untag_word(obj));
break;
@ -244,9 +220,6 @@ void factorbug(void)
fprintf(stderr,"Call frame:\n");
print_obj(callframe);
fprintf(stderr,"\n");
fprintf(stderr,"Executing:\n");
print_obj(executing);
fprintf(stderr,"\n");
}
else if(strcmp(cmd,"e") == 0)
{

3
native/error.c
View File

@ -33,9 +33,6 @@ void throw_error(CELL error, bool keep_stacks)
thrown_keep_stacks = keep_stacks;
thrown_ds = ds;
thrown_rs = rs;
thrown_cs = cs;
thrown_callframe = callframe;
thrown_executing = executing;
/* Return to run() method */
LONGJMP(stack_chain->toplevel,1);

6
native/error.h
View File

@ -24,13 +24,9 @@ bool throwing;
longjmps back to the top-level. */
CELL thrown_error;
CELL thrown_keep_stacks;
/* Since longjmp restores registers, we must save all these values.
On x86, only the first is in a register; on PowerPC, all are. */
/* Since longjmp restores registers, we must save all these values. */
CELL thrown_ds;
CELL thrown_rs;
CELL thrown_cs;
CELL thrown_callframe;
CELL thrown_executing;
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);

3
native/factor.c
View File

@ -11,9 +11,10 @@ void init_factor(const char* image,
init_stacks(ds_size,rs_size,cs_size);
/* callframe must be valid in case load_image() does GC */
callframe = F;
callframe_scan = callframe_end = 0;
thrown_error = F;
load_image(image,literal_size);
callframe = userenv[BOOT_ENV];
call(userenv[BOOT_ENV]);
init_c_io();
init_signals();
userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));

8
native/factor.h
View File

@ -58,8 +58,11 @@ CELL cs;
/* TAGGED currently executing quotation */
CELL callframe;
/* TAGGED pointer to currently executing word */
CELL executing;
/* UNTAGGED currently executing word in quotation */
CELL callframe_scan;
/* UNTAGGED end of quotation */
CELL callframe_end;
#include <errno.h>
#include <fcntl.h>
@ -100,7 +103,6 @@ CELL executing;
#include "word.h"
#include "run.h"
#include "signal.h"
#include "cons.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"

45
native/gc.c
View File

@ -64,6 +64,16 @@ void init_arena(CELL gens, CELL young_size, CELL aging_size)
cards_scanned = 0;
}
void collect_callframe_triple(CELL *callframe,
CELL *callframe_scan, CELL *callframe_end)
{
*callframe_scan -= *callframe;
*callframe_end -= *callframe;
copy_handle(callframe);
*callframe_scan += *callframe;
*callframe_end += *callframe;
}
void collect_stack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
@ -73,6 +83,16 @@ void collect_stack(BOUNDED_BLOCK *region, CELL top)
copy_handle((CELL*)ptr);
}
void collect_callstack(BOUNDED_BLOCK *region, CELL top)
{
CELL bottom = region->start;
CELL ptr;
for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
collect_callframe_triple((CELL*)ptr,
(CELL*)ptr + 1, (CELL*)ptr + 2);
}
void collect_roots(void)
{
int i;
@ -82,8 +102,7 @@ void collect_roots(void)
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
copy_handle(&executing);
copy_handle(&callframe);
collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
save_stacks();
stacks = stack_chain;
@ -92,9 +111,12 @@ void collect_roots(void)
{
collect_stack(stacks->data_region,stacks->data);
collect_stack(stacks->retain_region,stacks->retain);
collect_stack(stacks->call_region,stacks->call);
collect_callstack(stacks->call_region,stacks->call);
collect_callframe_triple(&stacks->callframe,
&stacks->callframe_scan,&stacks->callframe_end);
copy_handle(&stacks->callframe);
copy_handle(&stacks->catch_save);
stacks = stacks->next;
@ -212,19 +234,8 @@ INLINE void collect_object(CELL scan)
CELL collect_next(CELL scan)
{
CELL size;
if(headerp(get(scan)))
{
size = untagged_object_size(scan);
collect_object(scan);
}
else
{
size = CELLS;
copy_handle((CELL*)scan);
}
CELL size = untagged_object_size(scan);
collect_object(scan);
return scan + size;
}

1
native/image.c
View File

@ -5,7 +5,6 @@ void init_objects(HEADER *h)
int i;
for(i = 0; i < USER_ENV; i++)
userenv[i] = F;
executing = F;
userenv[GLOBAL_ENV] = h->global;
userenv[BOOT_ENV] = h->boot;
T = h->t;

19
native/memory.c
View File

@ -15,9 +15,6 @@ CELL object_size(CELL pointer)
case BIGNUM_TYPE:
size = untagged_object_size(UNTAG(pointer));
break;
case CONS_TYPE:
size = sizeof(F_CONS);
break;
case OBJECT_TYPE:
if(pointer == F)
size = 0;
@ -181,7 +178,7 @@ void primitive_next_object(void)
{
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL size, type;
CELL type;
if(!heap_scan)
general_error(ERROR_HEAP_SCAN,F,F,true);
@ -192,18 +189,8 @@ void primitive_next_object(void)
return;
}
if(headerp(value))
{
size = align8(untagged_object_size(heap_scan_ptr));
type = untag_header(value);
}
else
{
size = CELLS * 2;
type = CONS_TYPE;
}
heap_scan_ptr += size;
type = untag_header(value);
heap_scan_ptr += align8(untagged_object_size(heap_scan_ptr));
if(type < HEADER_TYPE)
dpush(RETAG(obj,type));

46
native/memory.h
View File

@ -42,7 +42,7 @@ INLINE void bput(CELL where, BYTE what)
INLINE CELL align8(CELL a)
{
return ((a & 7) == 0) ? a : ((a + 8) & ~7);
return (a + 7) & ~7;
}
#define TAG_MASK 7
@ -54,7 +54,6 @@ INLINE CELL align8(CELL a)
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define CONS_TYPE 2
#define OBJECT_TYPE 3
#define RATIO_TYPE 4
#define FLOAT_TYPE 5
@ -89,13 +88,6 @@ CELL T;
#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
INLINE bool headerp(CELL cell)
{
return (cell != F
&& TAG(cell) == OBJECT_TYPE
&& cell < RETAG(TYPE_COUNT << TAG_BITS,OBJECT_TYPE));
}
INLINE CELL tag_header(CELL cell)
{
return RETAG(cell << TAG_BITS,OBJECT_TYPE);
@ -113,35 +105,23 @@ INLINE CELL tag_object(void* cell)
INLINE CELL object_type(CELL tagged)
{
if(tagged == F)
return F_TYPE;
else
return untag_header(get(UNTAG(tagged)));
}
INLINE void type_check(CELL type, CELL tagged)
{
if(type < HEADER_TYPE)
{
if(TAG(tagged) == type)
return;
}
else if(TAG(tagged) == OBJECT_TYPE
&& object_type(tagged) == type)
{
return;
}
type_error(type,tagged);
return untag_header(get(UNTAG(tagged)));
}
INLINE CELL type_of(CELL tagged)
{
CELL tag = TAG(tagged);
if(tag == OBJECT_TYPE)
return object_type(tagged);
if(tagged == F)
return F_TYPE;
else if(TAG(tagged) == FIXNUM_TYPE)
return FIXNUM_TYPE;
else
return tag;
return object_type(tagged);
}
INLINE void type_check(CELL type, CELL tagged)
{
if(type_of(tagged) != type)
type_error(type,tagged);
}
CELL untagged_object_size(CELL pointer);

1
native/primitives.c
View File

@ -8,7 +8,6 @@ void* primitives[] = {
primitive_call,
primitive_ifte,
primitive_dispatch,
primitive_cons,
primitive_vector,
primitive_rehash_string,
primitive_sbuf,

13
native/relocate.c
View File

@ -44,17 +44,8 @@ void relocate_object(CELL relocating)
INLINE CELL relocate_data_next(CELL relocating)
{
CELL size = CELLS;
CELL cell = get(relocating);
if(headerp(cell))
{
size = untagged_object_size(relocating);
relocate_object(relocating);
}
else if(cell != F)
data_fixup((CELL*)relocating);
CELL size = untagged_object_size(relocating);
relocate_object(relocating);
return relocating + size;
}

45
native/run.c
View File

@ -5,6 +5,30 @@ INLINE void execute(F_WORD* word)
((XT)(word->xt))(word);
}
void call(CELL quot)
{
F_ARRAY *untagged;
if(quot == F)
return;
type_check(QUOTATION_TYPE,quot);
/* tail call optimization */
if(callframe_scan < callframe_end)
{
put(cs + CELLS,callframe);
put(cs + CELLS * 2,callframe_scan);
put(cs + CELLS * 3,callframe_end);
cs += CELLS * 3;
}
callframe = quot;
untagged = (F_ARRAY*)UNTAG(quot);
callframe_scan = AREF(untagged,0);
callframe_end = AREF(untagged,array_capacity(untagged));
}
/* Called from platform_run() */
void handle_error(void)
{
@ -13,17 +37,10 @@ void handle_error(void)
if(thrown_keep_stacks)
{
ds = thrown_ds;
cs = thrown_cs;
rs = thrown_rs;
callframe = thrown_callframe;
executing = thrown_executing;
}
else
{
fix_stacks();
callframe = F;
executing = F;
}
dpush(thrown_error);
/* Notify any 'catch' blocks */
@ -38,19 +55,20 @@ void run(void)
for(;;)
{
if(callframe == F)
if(callframe_scan == callframe_end)
{
if(cs_bot - cs == CELLS)
return;
callframe = cpop();
executing = cpop();
callframe_end = get(cs);
callframe_scan = get(cs - CELLS);
callframe = get(cs - CELLS * 2);
cs -= CELLS * 3;
continue;
}
callframe = (CELL)untag_cons(callframe);
next = get(callframe);
callframe = get(callframe + CELLS);
next = get(callframe_scan);
callframe_scan += CELLS;
switch(type_of(next))
{
@ -91,7 +109,6 @@ void undefined(F_WORD* word)
void docol(F_WORD* word)
{
call(word->def);
executing = tag_object(word);
}
/* pushes word parameter */

12
native/run.h
View File

@ -76,17 +76,7 @@ INLINE void rpush(CELL top)
put(rs,top);
}
INLINE void call(CELL quot)
{
/* tail call optimization */
if(callframe != F)
{
cpush(executing);
cpush(callframe);
}
callframe = quot;
}
void call(CELL quot);
void handle_error();
void run(void);

60
native/stack.c
View File

@ -61,6 +61,8 @@ void nest_stacks(void)
new_stacks->cards_offset = cards_offset;
new_stacks->callframe = callframe;
new_stacks->callframe_scan = callframe_scan;
new_stacks->callframe_end = callframe_end;
new_stacks->catch_save = userenv[CATCHSTACK_ENV];
new_stacks->data_region = alloc_bounded_block(ds_size);
@ -71,6 +73,7 @@ void nest_stacks(void)
stack_chain = new_stacks;
callframe = F;
callframe_scan = callframe_end = 0;
reset_datastack();
reset_retainstack();
reset_callstack();
@ -92,6 +95,8 @@ void unnest_stacks(void)
cards_offset = old_stacks->cards_offset;
callframe = old_stacks->callframe;
callframe_scan = old_stacks->callframe_scan;
callframe_end = old_stacks->callframe_end;
userenv[CATCHSTACK_ENV] = old_stacks->catch_save;
stack_chain = old_stacks->next;
@ -239,8 +244,8 @@ void primitive_from_r(void)
F_VECTOR* stack_to_vector(CELL bottom, CELL top)
{
CELL depth = (top - bottom + CELLS) / CELLS;
F_VECTOR* v = vector(depth);
F_ARRAY* a = untag_array_fast(v->array);
F_VECTOR *v = vector(depth);
F_ARRAY *a = untag_array_fast(v->array);
memcpy(a + 1,(void*)bottom,depth * CELLS);
v->top = tag_fixnum(depth);
return v;
@ -261,7 +266,26 @@ void primitive_retainstack(void)
void primitive_callstack(void)
{
maybe_gc(0);
dpush(tag_object(stack_to_vector(cs_bot,cs)));
CELL depth = (cs - cs_bot + CELLS) / CELLS;
F_VECTOR *v = vector(depth);
F_ARRAY *a = untag_array_fast(v->array);
CELL i;
CELL ptr = cs_bot;
for(i = 0; i < depth; i += 3, ptr += 3 * CELLS)
{
CELL quot = get(ptr);
CELL untagged = UNTAG(quot);
CELL position = UNAREF(untagged,get(ptr + CELLS));
CELL end = UNAREF(untagged,get(ptr + CELLS * 2));
put(AREF(a,i),quot);
put(AREF(a,i + 1),tag_fixnum(position));
put(AREF(a,i + 2),tag_fixnum(end));
}
v->top = tag_fixnum(depth);
dpush(tag_object(v));
}
/* returns pointer to top of stack */
@ -285,5 +309,33 @@ void primitive_set_retainstack(void)
void primitive_set_callstack(void)
{
cs = vector_to_stack(untag_vector(dpop()),cs_bot);
F_VECTOR *v = untag_vector(dpop());
F_ARRAY *a = untag_array_fast(v->array);
CELL depth = untag_fixnum_fast(v->top);
depth -= (depth % 3);
CELL i, ptr;
for(i = 0, ptr = cs_bot; i < depth; i += 3, ptr += 3 * CELLS)
{
CELL quot = get(AREF(a,i));
type_check(QUOTATION_TYPE,quot);
F_ARRAY *untagged = (F_ARRAY*)UNTAG(quot);
CELL length = array_capacity(untagged);
F_FIXNUM position = to_fixnum(get(AREF(a,i + 1)));
F_FIXNUM end = to_fixnum(get(AREF(a,i + 2)));
if(end < 0) end = 0;
if(end > length) end = length;
if(position < 0) position = 0;
if(position > end) position = end;
put(ptr,quot);
put(ptr + CELLS,AREF(untagged,position));
put(ptr + CELLS * 2,AREF(untagged,end));
}
cs = cs_bot + depth * CELLS - CELLS;
}

2
native/stack.h
View File

@ -19,6 +19,8 @@ typedef struct _STACKS {
BOUNDED_BLOCK *call_region;
/* saved callframe on entry to callback */
CELL callframe;
CELL callframe_scan;
CELL callframe_end;
/* saved catchstack on entry to callback */
CELL catch_save;
/* saved cards_offset register on entry to callback */