dataxchn.src

来自「没有说明」· SRC 代码 · 共 1,159 行 · 第 1/3 页

    if (namelist == 0) or (rows(namelist) /= nvars);
        fmt[.,1] = 0 $+ dxname $+ ftocv(seqa(1,1,nvars),1,0);
    else;
        fmt[.,1] = namelist;
    endif;
    fmt[.,2] = dx_setvec(_dxtype,nvars);
    fmt[.,3] = dx_setvec(_dxwidth,nvars);
    fmt[.,4] = dx_setvec(_dxprcn,nvars);
    retp(fmt);
endp;

/**********************************************************************
**                   Format check
***********************************************************************/
proc dx_setvec(v,n);
    local ee, msg;
    ee = ones(n,1);
    if (rows(v) == 1) or (rows(v) == n);
        retp(ee.*v);
    else;
        msg = " The number of elements in a descriptor (names, type, width,"\
            " prcn)\r\l         does not match the number of columns in the"\
            " export matrix";
        errorlog msg;
        retp(ee);
    endif;
endp;

/**********************************************************************
**                   Process range
***********************************************************************/
proc 2 = dx_range(r);
    local s,rn, i, ix, nowtype, newtype, c;

    if (r $== "");
        retp(r,0);
    endif;          /* range not specified */

    s = strindx(r,".",1) + strindx(r,":",1) + strindx(r,",",1);
    if (s == 0);
        retp(r,1);
    endif;          /* named range */

    r = upper(r);
    s = strlen(r);
    rn = zeros(5,1);
    ix = 1;
    i = 1;
    nowtype = 2;    /* type = 0 - not rec, 1 - num, 2 - char, 3 - delin  */
    do until i > s;
        c = vals(strsect(r,i,1));
        newtype = 1*( (c >= 48) .and (c <= 57) ) + 2*( (c >= 65) .and (c <=
            90) ) + 3*( (c == 46) .or (c == 58) .or (c == 44));
        if (newtype /= nowtype);
            ix = ix + 1;
            if ix > 5;
                goto rngmsg;
            endif;
            nowtype = newtype;
        endif;
        if nowtype == 1;    /* number */
            rn[ix] = 10*rn[ix] + c - 48;
        elseif nowtype == 2;        /* character */
            rn[ix] = 26*rn[ix] + c - 64;
        elseif nowtype == 0;        /* not recognized */
            goto rngmsg;    /* syntax error */
        endif;
        i = i+1;
    endo;
    let ix = 1 2 4 5;
    rn = rn[ix] -1;

    retp(rn,2);     /* stated range */

rngmsg:

    errorlog "Syntax error with range";
    retp(0,-1);     /* syntax error */

endp;

/**********************************************************************
**                   Print routines
***********************************************************************/
proc dx_print(msg);
    if not _dxprint;
        retp("");
    endif;
    print /flush msg;
    retp("");
endp;

proc 0 = dx_header(stng);
    call dx_print("");
    call dx_print(chrs(ones(75,1)*42));
    call dx_print( "                          " $+ stng );
    call dx_print(chrs(ones(75,1)*42));
    call dx_print("");
endp;

proc 0 = dx_version();
    local errmsg, ret;
    errmsg = chrs(32*ones(1000,1));
    ret = 0;
    dllcall version(ret,errmsg);
    cls;
    errmsg;
endp;

/**********************************************************************
**                   Schema Routines
***********************************************************************/
proc dx_parse(fname,range);
    local fieldno, curcol, delim, name, tok, msg, sch, tval, tchar, t1, t2,
        tt, stype, strtcol, swidth, root, nstr, ns1, n1, ns2, n2, ns, ss,
        firstname,lastname, curname, scurcol, rtok, nlen, i,j, f1, str,
        sindx, spath, filename, froot, slen, schema, eol, schstng, ret,
        nwrite, prcnlst, prcn, nvars;

    str = range;    /* user defined schema */
    sindx = strrindx(fname,"\\",-1);
    spath = strsect(fname,1,sindx);
    slen = strlen(fname) - sindx;
    filename = strsect(fname,sindx+1,slen);
    sindx = strindx(filename,".", 1);
    froot = strsect(filename,1,sindx-1);
    schema = spath $+ froot $+ ".sch";
    ret = 0;
    dllcall dx_deletefile(ret,schema);

    if str $== 0;
        retp(18);
    endif;          /* return ftype (18) */

    eol = "\n";     /* chrs(13|10); */
    prcnlst = zeros(255,1);
    schstng = "[" $+ upper(froot) $+ "]" $+ eol;
    schstng = schstng $+ "Filetype=Fixed" $+ eol;
    if _dxaschdr;
        schstng = schstng $+ "Names=in-file" $+ eol;
    else;
        schstng = schstng $+ "Names=not-in-file" $+ eol;
    endif;
    schstng = schstng $+ "Dec-Point=." $+ eol;
    schstng = schstng $+ "CharSet=ascii" $+ eol;

    fieldno = 1;
    curcol = 0;     /* zero based */
    /* Get field name */
    let delim = 32;

    do while 1;

        if strlen(str) == 0;
            break;
        endif;

        { name,str,tok } = strtok(str,delim);

        if not isalpha(strsect(name,1,1));          /* first element of name
                                                    :: must be alpha
                                                    */
            msg = "Syntax error - field name expected";
            goto err;
        endif;

        { firstname,lastname,rtok } = strtok(name,45);      /* see if range */

        if rtok;    /* process range */
            tt = firstname;
            gosub numfind;
            n1 = stof(nstr);
            tt = lastname;
            gosub numfind;
            ns2 = nstr;
            n2 = stof(nstr);
            nlen = strlen(ns2);
            ns1 = ftocv(n1,nlen,0);

        else;       /* not range */
            root = name;
            n1 = 1;
            n2 = 1;
            ns1 = "";
            ns2 = "";
            nlen = 1;
        endif;

        /* Get type */
        { tval,str,tok } = strtok(str,delim);
        tchar = strsect(tval,1,1);
        if tchar $== "$";
            stype = "Char,";
            { tval,str,tok } = strtok(str,delim);
        else;
            stype = "Float,";
        endif;

        /* Get cols */
        { t1,t2,tok } = strtok(tval,45);    /* looking for 6-10 */
        if tok == 45;
            tt = t1;
            gosub numchk;
            tt = t2;
            gosub numchk;
            curcol = stof(t1)-1;
            swidth = ftocv((stof(t2)-stof(t1)+1),1,0);
            prcn = "";
            goto schwrite;
        endif;

        { t1,t2,tok } = strtok(tval,44);    /* looking for 6,5 or 6,
                                            :: 5.2
                                            */
        if tok == 44;
            tt = t1;
            gosub numchk;
            tt = t2;
            gosub numchk;
            curcol = stof(t1) -1;
            { swidth,prcn,tok } = strtok(t2,46);    /* looking for decimal pt */
            goto schwrite;
        endif;

        tt = t1;
        gosub numchk;       /* looking for 5 or 5.2 */
        { swidth,prcn,tok } = strtok(t1,46);        /* looking for decimal pt */
        goto schwrite;

    schwrite:

        ns = ns1;
        scurcol = ftocv(curcol,1,0);
        j = n1;
        do until j > n2;
            curname = root $+ ns;
            sch = "Field" $+ ftocv(fieldno,1,0) $+ "=" $+ curname $+ "," $+
                stype $+ swidth $+ ",0," $+ scurcol;
            prcnlst[fieldno] = stof(prcn);
            curcol = curcol + stof(swidth);
            scurcol = ftocv(curcol,1,0);
            fieldno = fieldno + 1;
            schstng = schstng $+ sch $+ eol;
            j = j+1;
            ns = ftocv(j,nlen,0);
        endo;

    endo;
    print " ";
    nvars = fieldno - 1;
    /* schstng; */
    f1 = fopen(schema,"w");
    if f1 == 0;
        msg = "File error - could not open " $+ schema;
        goto err;
    endif;

    nwrite = fputs(f1,schstng);
    if nwrite == 0;
        msg = "File write error " $+ schema;
        goto err;
    endif;

    closeall;
    _dxprcn = prcnlst[1:nvars];     /* save list */

    retp(19);       /* return file type (19) packed ASCII */

numchk:

    if not isnumber(tt);
        msg = "Syntax error - number expected";
        goto err;
    endif;
    return;

numfind:

    ns = strlen(tt);
    nstr = "";
    i = ns;
    do while 1;
        ss = strsect(tt,i,1);
        if not isnumber(ss);
            break;
        endif;
        nstr = ss $+ nstr;
        i = i-1;
    endo;
    root = strsect(tt,1,i);
    return;

err:

    errorlog msg;
    retp(miss(0,0));
endp;

/**********************************************************************
**                   Utilities
***********************************************************************/

proc isalpha(char);
    local alpha,t;
    alpha = seqa(65,1,26)|95|seqa(97,1,26);         /* A-Z, _, a-z  */
    t = not ismiss(indnv(vals(char),alpha));
    retp(t);
endp;

proc isnumber(char);
    local num,t;
    num = 46|seqa(48,1,10);         /* ., 0-9 */
    t = not ismiss(indnv(vals(char),num));
    retp(t);
endp;

proc issymbol(char,sym);
    retp(char $== sym);
endp;

proc (3) = strtok(str,delim);
    local i,n,cmdvec,tok, dval, j1, j2, j3;
    clear j1, j2, j3, dval;
    if strlen(str) == 0;
        retp("","",dval);
    endif;
    cmdvec = vals(str);
    cmdvec = miss(cmdvec,13);
    cmdvec = miss(cmdvec,10);
    cmdvec = missrv(cmdvec,32);
    n = rows(cmdvec);
    i = 1;

    /* find first non delim char */
    do while i <= n;
        dval = indnv(cmdvec[i],delim);
        if ismiss(dval);
            j1 = i;
            break;
        endif;
        i = i+1;
    endo;
    if i > n;
        retp("","",0);
    endif;
    i = i+1;
    if i > n;
        retp(chrs(cmdvec[j1:n]),"",0);
    endif;

    /* find first delim char */

    dval = minc(indnv(delim,cmdvec[i:n]));
    if ismiss(dval);
        retp(chrs(cmdvec[j1:n]),"",0);
    else;
        j2 = j1+ dval - 1;
        i = j2;
        tok = (cmdvec[j2+1]);
    endif;

    /* now find first non delim char */
    i = j2 + 1;
    if i > n;
        retp(chrs(cmdvec[j1:j2]),"",0);
    endif;
    do while i <= n;
        dval = indnv(cmdvec[i],delim);
        if ismiss(dval);
            j3 = i;
            break;
        endif;
        i = i+1;
    endo;

    if i > n;
        retp(chrs(cmdvec[j1:j2]),"",tok);
    else;
        retp(chrs(cmdvec[j1:j2]),chrs(cmdvec[j3:n]),tok);
    endif;
endp;

/***********************************************************************/
#endif