vbscript: Implement redim preserve.

dlls/vbscript/compile.c

@@ -1128,16 +1128,18 @@ static HRESULT compile_redim_statement(compile_ctx_t *ctx, redim_statement_t *st
     unsigned arg_cnt;
     HRESULT hres;
 
-    if(stat->preserve) {
-        FIXME("Preserving redim not supported\n");
-        return E_NOTIMPL;
-    }
-
     hres = compile_args(ctx, stat->dims, &arg_cnt);
     if(FAILED(hres))
         return hres;
 
-    return push_instr_bstr_uint(ctx, OP_redim, stat->identifier, arg_cnt);
+    hres = push_instr_bstr_uint(ctx, stat->preserve ? OP_redim_preserve : OP_redim, stat->identifier, arg_cnt);
+    if(FAILED(hres))
+	return hres;
+
+    if(!emit_catch(ctx, 0))
+        return E_OUTOFMEMORY;
+
+    return S_OK;
 }
 
 static HRESULT compile_const_statement(compile_ctx_t *ctx, const_statement_t *stat)

dlls/vbscript/interp.c

@@ -1291,6 +1291,63 @@ static HRESULT interp_redim(exec_ctx_t *ctx)
     return S_OK;
 }
 
+static HRESULT interp_redim_preserve(exec_ctx_t *ctx)
+{
+    BSTR identifier = ctx->instr->arg1.bstr;
+    const unsigned dim_cnt = ctx->instr->arg2.uint;
+    unsigned i;
+    SAFEARRAYBOUND *bounds;
+    SAFEARRAY *array;
+    ref_t ref;
+    HRESULT hres;
+
+    TRACE("%s %u\n", debugstr_w(identifier), dim_cnt);
+
+    hres = lookup_identifier(ctx, identifier, VBDISP_LET, &ref);
+    if(FAILED(hres)) {
+        FIXME("lookup %s failed: %08x\n", debugstr_w(identifier), hres);
+        return hres;
+    }
+
+    if(ref.type != REF_VAR) {
+        FIXME("got ref.type = %d\n", ref.type);
+        return E_FAIL;
+    }
+
+    if(!(V_VT(ref.u.v) & VT_ARRAY)) {
+        FIXME("ReDim Preserve not valid on type %d\n", V_VT(ref.u.v));
+        return E_FAIL;
+    }
+
+    array = V_ARRAY(ref.u.v);
+
+    hres = array_bounds_from_stack(ctx, dim_cnt, &bounds);
+    if(FAILED(hres))
+        return hres;
+
+    if(array == NULL || array->cDims == 0) {
+        /* can initially allocate the array */
+        array = SafeArrayCreate(VT_VARIANT, dim_cnt, bounds);
+        VariantClear(ref.u.v);
+        V_VT(ref.u.v) = VT_ARRAY|VT_VARIANT;
+        V_ARRAY(ref.u.v) = array;
+        return S_OK;
+    } else if(array->cDims != dim_cnt) {
+        /* can't otherwise change the number of dimensions */
+        TRACE("Can't resize %s, cDims %d != %d\n", debugstr_w(identifier), array->cDims, dim_cnt);
+        return MAKE_VBSERROR(VBSE_OUT_OF_BOUNDS);
+    } else {
+        /* can resize the last dimensions (if others match */
+        for(i = 0; i+1 < dim_cnt; ++i) {
+            if(array->rgsabound[array->cDims - 1 - i].cElements != bounds[i].cElements) {
+                TRACE("Can't resize %s, bound[%d] %d != %d\n", debugstr_w(identifier), i, array->rgsabound[i].cElements, bounds[i].cElements);
+                return MAKE_VBSERROR(VBSE_OUT_OF_BOUNDS);
+            }
+        }
+        return SafeArrayRedim(array, &bounds[dim_cnt-1]);
+    }
+}
+
 static HRESULT interp_step(exec_ctx_t *ctx)
 {
     const BSTR ident = ctx->instr->arg2.bstr;

dlls/vbscript/tests/lang.vbs

@@ -1412,6 +1412,28 @@ x = 1
 redim x(3)
 ok ubound(x) = 3, "ubound(x) = " & ubound(x)
 
+x(0) = 1
+x(1) = 2
+x(2) = 3
+x(2) = 4
+
+redim preserve x(1)
+ok ubound(x) = 1, "ubound(x) = " & ubound(x)
+ok x(0) = 1, "x(0) = " & x(1)
+ok x(1) = 2, "x(1) = " & x(1)
+
+redim preserve x(2)
+ok ubound(x) = 2, "ubound(x) = " & ubound(x)
+ok x(0) = 1, "x(0) = " & x(0)
+ok x(1) = 2, "x(1) = " & x(1)
+ok x(2) = vbEmpty, "x(2) = " & x(2)
+
+on error resume next
+redim preserve x(2,2)
+e = err.number
+on error goto 0
+ok e = 9, "e = " & e ' VBSE_OUT_OF_BOUNDS, cannot change cDims
+
 x = Array(1, 2)
 redim x(-1)
 ok lbound(x) = 0, "lbound(x) = " & lbound(x)
@@ -1422,6 +1444,40 @@ ok ubound(x) = 3, "ubound(x) = " & ubound(x)
 ok ubound(x, 1) = 3, "ubound(x, 1) = " & ubound(x, 1)
 ok ubound(x, 2) = 2, "ubound(x, 2) = " & ubound(x, 2) & " expected 2"
 
+redim x(1, 3)
+x(0,0) = 1.1
+x(0,1) = 1.2
+x(0,2) = 1.3
+x(0,3) = 1.4
+x(1,0) = 2.1
+x(1,1) = 2.2
+x(1,2) = 2.3
+x(1,3) = 2.4
+
+redim preserve x(1,1)
+ok ubound(x, 1) = 1, "ubound(x, 1) = " & ubound(x, 1)
+ok ubound(x, 2) = 1, "ubound(x, 2) = " & ubound(x, 2)
+ok x(0,0) = 1.1, "x(0,0) = " & x(0,0)
+ok x(0,1) = 1.2, "x(0,1) = " & x(0,1)
+ok x(1,0) = 2.1, "x(1,0) = " & x(1,0)
+ok x(1,1) = 2.2, "x(1,1) = " & x(1,1)
+
+redim preserve x(1,2)
+ok ubound(x, 1) = 1, "ubound(x, 1) = " & ubound(x, 1)
+ok ubound(x, 2) = 2, "ubound(x, 2) = " & ubound(x, 2)
+ok x(0,0) = 1.1, "x(0,0) = " & x(0,0)
+ok x(0,1) = 1.2, "x(0,1) = " & x(0,1)
+ok x(1,0) = 2.1, "x(1,0) = " & x(1,0)
+ok x(1,1) = 2.2, "x(1,1) = " & x(1,1)
+ok x(0,2) = vbEmpty, "x(0,2) = " & x(0,2)
+ok x(1,2) = vbEmpty, "x(1,2) = " & x(1,1)
+
+on error resume next
+redim preserve x(2,2)
+e = err.number
+on error goto 0
+ok e = 9, "e = " & e ' VBSE_OUT_OF_BOUNDS, can only change rightmost dimension
+
 dim staticarray(4)
 on error resume next
 redim staticarray(3)

dlls/vbscript/vbscript.h

@@ -265,6 +265,7 @@ typedef enum {
     X(or,             1, 0,           0)          \
     X(pop,            1, ARG_UINT,    0)          \
     X(redim,          1, ARG_BSTR,    ARG_UINT)   \
+    X(redim_preserve, 1, ARG_BSTR,    ARG_UINT)   \
     X(ret,            0, 0,           0)          \
     X(retval,         1, 0,           0)          \
     X(set_ident,      1, ARG_BSTR,    ARG_UINT)   \