diff options
Diffstat (limited to 'pkg/dataio/import/generic')
| -rw-r--r-- | pkg/dataio/import/generic/ipdb.x | 813 | ||||
| -rw-r--r-- | pkg/dataio/import/generic/ipfio.x | 569 | ||||
| -rw-r--r-- | pkg/dataio/import/generic/ipobands.x | 375 | ||||
| -rw-r--r-- | pkg/dataio/import/generic/ipproc.x | 921 | ||||
| -rw-r--r-- | pkg/dataio/import/generic/mkpkg | 15 |
5 files changed, 2693 insertions, 0 deletions
diff --git a/pkg/dataio/import/generic/ipdb.x b/pkg/dataio/import/generic/ipdb.x new file mode 100644 index 00000000..4dfb81c7 --- /dev/null +++ b/pkg/dataio/import/generic/ipdb.x @@ -0,0 +1,813 @@ +include <evvexpr.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false + + +# IP_EVAL_DBREC -- For each of the keywords defined in the database record, +# evaluate the expression and load the task structure. + +procedure ip_eval_dbrec (ip) + +pointer ip #i task struct pointer + +int ival +pointer sp, dims, pixtype, err +pointer np, stp, sym + +pointer stname(), sthead(), stnext +int or(), ip_dbgeti() +bool streq() + +errchk ip_dbgeti() + +begin + call smark (sp) + call salloc (dims, SZ_EXPR, TY_CHAR) + call salloc (pixtype, SZ_EXPR, TY_CHAR) + call salloc (err, SZ_EXPR, TY_CHAR) + call aclrc (Memc[dims], SZ_EXPR) + call aclrc (Memc[pixtype], SZ_EXPR) + call aclrc (Memc[err], SZ_EXPR) + + # Load the defaults. + call ip_load_defaults (ip) + + # First thing we do is get the byte swap flag so the remaining + # fields will be interpreted correctly. + ifnoerr (ival = ip_dbgeti (ip, "bswap")) + IP_SWAP(ip) = ival + + # Next, we handle 'interleave', 'dims' and 'pixtype' as a special case + # since for band- and line-interleaved files we may need to fix up the + # pixtype pointers. + ifnoerr (ival = ip_dbgeti (ip, "interleave")) + IP_INTERLEAVE(ip) = ival + + ifnoerr (call ip_dbstr (ip, "dims", Memc[dims], SZ_EXPR)) + call ip_do_dims (ip, Memc[dims]) + + ifnoerr (call ip_dbstr (ip, "pixtype", Memc[pixtype], SZ_EXPR)) { + if (Memc[pixtype] == '"') + call fdb_strip_quote (Memc[pixtype], Memc[pixtype], SZ_EXPR) + call ip_do_pixtype (ip, Memc[pixtype]) + } + + # Loop over every symbol in the table. + stp = IP_FSYM(ip) + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) { + np = stname (stp, sym) + + if (streq(Memc[np],"format") || # ignored or found already + streq(Memc[np],"alias") || + streq(Memc[np],"image_id") || + streq(Memc[np],"interleave") || + streq(Memc[np],"dims") || + streq(Memc[np],"pixtype") || + streq(Memc[np],"id_string") || + streq(Memc[np],"bswap")) { + next + } else if (streq(Memc[np],"hskip")) { + IP_HSKIP(ip) = ip_dbgeti (ip, "hskip") + } else if (streq(Memc[np],"tskip")) { + IP_TSKIP(ip) = ip_dbgeti (ip, "tskip") + } else if (streq(Memc[np],"bskip")) { + IP_BSKIP(ip) = ip_dbgeti (ip, "bskip") + } else if (streq(Memc[np],"lskip")) { + IP_LSKIP(ip) = ip_dbgeti (ip, "lskip") + } else if (streq(Memc[np],"lpad")) { + IP_LPAD(ip) = ip_dbgeti (ip, "lpad") + } else if (streq(Memc[np],"yflip")) { + if (ip_dbgeti (ip, "yflip") == YES) + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + } else if (streq(Memc[np],"error")) { + if (IP_OUTPUT(ip) != IP_INFO) + call ip_do_error (ip, Memc[P2C(sym)]) + } else if (streq(Memc[np],"comment")) { + call fdb_strip_quote (Memc[P2C(sym)], Memc[P2C(sym)], SZ_LINE) + call ip_do_comment (ip, Memc[P2C(sym)]) + } else { + call eprintf ("Warning: Unknown database keyword '%s'.\n") + call pargstr (Memc[np]) + } + } + + if (DEBUG) { call zzi_prstruct ("eval dbrec:", ip) } + call sfree (sp) +end + + +# IP_LOAD_DEFAULTS -- Load the default input parameters to the task structure. + +procedure ip_load_defaults (ip) + +pointer ip #i task struct pointer + +begin + IP_SWAP(ip) = DEF_SWAP # type of byte swapping + IP_INTERLEAVE(ip) = DEF_INTERLEAVE # type of data interleaving + IP_HSKIP(ip) = DEF_HSKIP # bytes to skip before data + IP_TSKIP(ip) = DEF_TSKIP # bytes to skip after data + IP_BSKIP(ip) = DEF_BSKIP # bytes between image bands + IP_LSKIP(ip) = DEF_LSKIP # bytes to skip at front of + IP_LPAD(ip) = DEF_LPAD # bytes to skip at end of + + # zero image dimensions + for (IP_NDIM(ip)=IM_MAXDIM; IP_NDIM(ip) > 0; IP_NDIM(ip)=IP_NDIM(ip)-1) + IP_AXLEN(ip,IP_NDIM(ip)) = 0 +end + + +# IP_DBFCN -- Called by evvexpr to execute format database special functions. + +procedure ip_dbfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf, outstr +int fd, func, v_nargs +int i, len, nchar, ival, cur_offset, swap +char ch +short sval +real rval +double dval + +short ip_getb(), ip_gets() +int strdic(), ip_line(), ip_locate(), ip_getu() +int ctoi(), ctol(), ctor(), ctod(), ctocc(), ctowrd() +int and(), strlen(), clgeti() +long ip_getl() +real ip_getr(), ip_getn() +double ip_getd(), ip_getn8() +bool strne(), streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[outstr], SZ_LINE) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, DB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case CTOCC, CTOD, CTOI, CTOL, CTOR, CTOWRD: + v_nargs = -1 + + case GETSTR: + v_nargs = -1 + case GETB, GETU, GETI, GETI2, GETI4, GETR, GETR4, GETR8, + GETN, GETN4, GETN8: + v_nargs = 1 + + case LOCATE: + v_nargs = -1 + case LINE, SKIP: + v_nargs = 1 + + case BSWAP: + v_nargs = 1 + case PARAMETER, DEFAULT: + v_nargs = 1 + case SUBSTR: + v_nargs = 3 + case STRIDX: + v_nargs = 2 + case LSB_HOST, MSB_HOST: + v_nargs = 0 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + fd = IP_FD(ip) + swap = IP_SWAP(ip) + cur_offset = IP_OFFSET(ip) + + if (DEBUG) { + call eprintf ("cur_offset=%d nargs=%d func=%s swap=%d\n") + call pargi(cur_offset) ; call pargi(nargs) + call pargstr(fcn) ; call pargi (swap) + do i = 1, nargs + call zzi_pevop (args[i]) + call eprintf ("init op => ") ; call zzi_pevop(o) + + } + + # Evaluate the function. + switch (func) { + case CTOCC: # run the fmtio equivalents of the argument + if (nargs == 1) + ch = ip_getb (fd, O_VALI(args[1])) + else + ch = ip_getb (fd, cur_offset) + len = ctocc (ch, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len) + cur_offset = cur_offset + 1 + call ip_lseek (fd, cur_offset) + + case CTOWRD: + if (nargs == 1) + call ip_gstr (fd, O_VALI(args[1]), SZ_FNAME, Memc[outstr]) + else + call ip_gstr (fd, cur_offset, SZ_FNAME, Memc[outstr]) + nchar = ctowrd (Memc[outstr], i, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, nchar, TY_CHAR) + call aclrc (O_VALC(o), nchar) + call amovc (Memc[outstr], O_VALC(o), nchar) + cur_offset = cur_offset + nchar + 1 + call ip_lseek (fd, cur_offset) + + case CTOI: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_INT + + case CTOL: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_LONG + + case CTOR: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_REAL + + case CTOD: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_DOUBLE + + case GETSTR: + if (nargs == 1) { + call ip_gstr (fd, cur_offset, O_VALI(args[1]), Memc[outstr]) + cur_offset = cur_offset + O_VALI(args[1]) + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + cur_offset = O_VALI(args[1]) + O_VALI(args[2]) - 1 + } + if (strlen(Memc[outstr]) == 0) { + len = strlen ("ERR") + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call strcpy ("ERR", O_VALC(o), len-1) + } else { + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len-1) + } + + case GETB: + if (nargs == 0) { + sval = ip_getb (fd, cur_offset) + cur_offset = cur_offset + SZB_CHAR + } else { + sval = ip_getb (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + SZB_CHAR + } + ival = sval + O_TYPE(o) = TY_INT + + case GETU: + if (nargs == 0) { + sval = short (ip_getu (fd, cur_offset)) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = short (ip_getu (fd, O_VALI(args[1]))) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI, GETI2: + if (nargs == 0) { + sval = ip_gets (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = ip_gets (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI4: + if (nargs == 0) { + ival = ip_getl (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_LONG) + } else { + ival = ip_getl (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_LONG) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) + call bswap4 (ival, 1, ival, 1, (SZ_INT32*SZB_CHAR)) + O_TYPE(o) = TY_INT + + case GETR, GETR4: + if (nargs == 0) { + rval = ip_getr (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getr (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETR8: + if (nargs == 0) { + dval = ip_getd (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getd (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case GETN, GETN4: + if (nargs == 0) { + rval = ip_getn (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getn (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETN8: + if (nargs == 0) { + dval = ip_getn8 (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getn8 (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case LOCATE: # locate the pattern in the file + if (nargs == 1) + ival = ip_locate (fd, cur_offset, O_VALC(args[1])) + else if (nargs == 2) + ival = ip_locate (fd, O_VALI(args[1]), O_VALC(args[2])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case LINE: # locate the line no. in the file + ival = ip_line (fd, O_VALI(args[1])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case SKIP: # skip a certain number of bytes + ival = O_VALI(args[1]) + O_TYPE(o) = TY_INT + cur_offset = cur_offset + ival + + case BSWAP: # byte-swap argument + O_TYPE(o) = O_TYPE(args[1]) + switch (O_TYPE(args[1])) { + case TY_SHORT: + call bswap2 (O_VALS(args[1]), 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + case TY_INT: + call bswap4 (O_VALI(args[1]), 1, ival, 1, (SZ_INT32*SZB_CHAR)) + case TY_LONG: + call bswap4 (O_VALL(args[1]), 1, ival, 1, (SZ_LONG*SZB_CHAR)) + case TY_REAL: + call bswap4 (O_VALR(args[1]), 1, rval, 1, (SZ_REAL*SZB_CHAR)) + case TY_DOUBLE: + call bswap8 (O_VALD(args[1]), 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + } + + case PARAMETER: # return current task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call clgstr ("dims", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call clgstr ("pixtype", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = clgeti ("interleave") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + call clgstr ("bswap", Memc[outstr], SZ_FNAME) + if (strne("no",Memc[outstr]) && strne("none",Memc[outstr])) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = clgeti ("hskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = clgeti ("tskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = clgeti ("bskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = clgeti ("lskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = clgeti ("lpad") + O_TYPE(o) = TY_INT + } + + case DEFAULT: # return default task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = DEF_INTERLEAVE + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + ival = DEF_SWAP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = DEF_HSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = DEF_TSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = DEF_BSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = DEF_LSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = DEF_LPAD + O_TYPE(o) = TY_INT + } + + case LSB_HOST: # host is an LSB byte ordered machine + if (BYTE_SWAP2 == YES) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case MSB_HOST: # host is an MSB byte ordered machine + if (BYTE_SWAP2 == NO) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case SUBSTR: # return a substring of the argument + + case STRIDX: # return offset of a char w/in str + + } + + # Write result to output operand. + O_LEN(o) = 0 + switch (O_TYPE(o)) { + case TY_USHORT, TY_SHORT: + O_VALS(o) = sval + case TY_INT, TY_BOOL: + O_VALI(o) = ival + case TY_LONG: + O_VALL(o) = ival + case TY_REAL: + O_VALR(o) = rval + case TY_DOUBLE: + O_VALD(o) = dval + } + + if (DEBUG) { call eprintf("ip_dbfcn: ") ; call zzi_pevop (o) } + + IP_OFFSET(ip) = cur_offset + call sfree (sp) +end + + +# IP_DBSTR -- Get a string valued expression from the database. + +procedure ip_dbstr (ip, param, outstr, maxch) + +pointer ip #i task struct pointer +char param[ARB] #i parameter to evaluate +char outstr[ARB] #o result string +int maxch #i max length of string + +pointer sp, expr, o + +int locpr(), strlen() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPR) + + # Get the requested parameter. + call aclrc (outstr, SZ_EXPR) + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "FDBGET: Format parameter not found") + + if (DEBUG) { + call eprintf("ip_dbstr: expr='%s' len=%d ");call pargstr(Memc[expr]) + call pargi(strlen(Memc[expr])) + } + + # Evaluate the expression. + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) != TY_CHAR) + call error (0, "ip_dbstr: Expression must be a string valued") + else + call amovc (O_VALC(o), outstr, (min(strlen(O_VALC(o)),maxch))) + } then + call erract (EA_WARN) + + if (DEBUG) { call eprintf ("outstr=:%s:\n") ; call pargstr (outstr) } + + call evvfree (o) + call sfree (sp) +end + + + +# IP_DBGETI -- Get integer valued format parameter from the database. + +int procedure ip_dbgeti (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +int val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_INT && O_TYPE(o) != TY_SHORT) { + call error (0, "Expression must be an integer") + } else + val = O_VALI(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargi (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DBGETR -- Get real valued format parameter from the database. + +real procedure ip_dbgetr (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +real val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_REAL) { + call error (0, "Expression must be a real") + } else + val = O_VALR(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargr (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DO_ERROR -- Process the error parameter. + +procedure ip_do_error (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i error string + +pointer o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +bool strne() +errchk evvexpr + +begin + if (DEBUG) {call eprintf ("error expr: '%s' ") ; call pargstr (expr)} + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_dbfcn), ip, + EV_RNGCHK) + + if (DEBUG) { call eprintf("-> '%s'\n") ; call pargstr(O_VALC(o)) } + + if (O_TYPE(o) != TY_CHAR) + call error (2, "do_error: Expression must be a string valued") + else { + if (strne("okay",O_VALC(o))) + call error (2, O_VALC(o)) + } + call evvfree (o) + + } then + if (IP_OUTPUT(ip) != IP_INFO) + call erract (EA_FATAL) +end + + +# IP_DO_COMMENT - Process a comment line in the format database. + +procedure ip_do_comment (ip, comstr) + +pointer ip #i task struct pointer +char comstr[ARB] #i comment to add + +pointer sp, buf + +begin + # Copy the comment line to the comment block. + if (IP_COMPTR(ip) == NULL) + call calloc (IP_COMPTR(ip), SZ_COMMENT, TY_CHAR) + + if (COMMENT(ip) == '\0') { + call strcpy ("\t", COMMENT(ip), SZ_LINE) + call strcat (comstr, COMMENT(ip), SZ_LINE) + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + Memc[buf] = '\0' + call strcpy ("\t", Memc[buf], SZ_LINE) + call strcat (comstr, Memc[buf], SZ_LINE) + call strcat ("\n", Memc[buf], SZ_LINE) + call strcat (COMMENT(ip), Memc[buf], SZ_COMMENT) + + call strcpy (Memc[buf], COMMENT(ip), SZ_COMMENT) + + call sfree (sp) + } +end + + +# IP_INITOP - Initialize an operand pointer to the requested values + +procedure ip_initop (o, len, type) + +pointer o #u operand pointer +int len #i length of array +int type #i data type of operand + +begin + O_LEN(o) = len + O_TYPE(o) = type + if (len > 1) + call calloc (O_VALP(o), len, type) +end diff --git a/pkg/dataio/import/generic/ipfio.x b/pkg/dataio/import/generic/ipfio.x new file mode 100644 index 00000000..2977d8cb --- /dev/null +++ b/pkg/dataio/import/generic/ipfio.x @@ -0,0 +1,569 @@ +include <mach.h> +include <fset.h> +include "../import.h" + +define DEBUG false + + +# IP_GSTR -- Get a string of the specifed length from the given offset. + +procedure ip_gstr (fd, offset, len, outstr) + +int fd +int offset +int len +char outstr[ARB] + +int nstat, read() +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, len+2, TY_CHAR) + call aclrc (Memc[buf], len+2) + call aclrc (outstr, len+2) + + call ip_lseek (fd, offset) + nstat = read (fd, Memc[buf], len) + + if (mod(offset,2) == 0 && offset > 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, len) + call chrupk (Memc[buf], 1, outstr, 1, len) + + if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); + call pargstr(outstr) ; call pargi (len) } + call sfree (sp) +end + + +# IP_GETB -- Get a byte from the given offset. + +short procedure ip_getb (fd, offset) + +int fd +int offset + +int nstat, read() +short val +char buf[2] + +begin + call ip_lseek (fd, offset) + nstat = read (fd, buf, 2) + + if (mod(offset,2) == 0) + call bytmov (buf, 2, buf, 1, 2) + call chrupk (buf, 1, buf, 1, 2) + + if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) } + if (buf[1] < 0) + val = buf[1] + 256 + else + val = buf[1] + return (val) +end + + +# IP_GETU -- Get a unsigned short integer from the given offset. + +int procedure ip_getu (fd, offset) + +int fd +int offset + +int val +short ip_gets() + +begin + val = ip_gets (fd, offset) + if (val < 0) + val = val + 65536 + return (val) +end + +# IP_GET[silrd] -- Get a value of <type> from the given offset. + + + +short procedure ip_gets (fd, offset) + +int fd +int offset + +int nstat, read() +short val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_SHORT * SZB_CHAR) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargs(val) } + return (val) +end + + +int procedure ip_geti (fd, offset) + +int fd +int offset + +int nstat, read() +int val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargi(val) } + return (val) +end + + +long procedure ip_getl (fd, offset) + +int fd +int offset + +int nstat, read() +long val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargl(val) } + return (val) +end + + +real procedure ip_getr (fd, offset) + +int fd +int offset + +int nstat, read() +real val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_REAL * SZB_CHAR) + call ieeupkr (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargr(val) } + return (val) +end + + +double procedure ip_getd (fd, offset) + +int fd +int offset + +int nstat, read() +double val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_DOUBLE * SZB_CHAR) + call ieeupkd (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargd(val) } + return (val) +end + + +# IP_GETN -- Get a native floating point number from the given offset. + +real procedure ip_getn (fd, offset) + +int fd +int offset + +int nstat, read() +real rval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, rval, SZ_REAL) + + if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) } + return (rval) +end + + +# IP_GETN8 -- Get a native double precision floating point number from the +# given offset. + +double procedure ip_getn8 (fd, offset) + +int fd +int offset + +int nstat, read() +double dval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, dval, SZ_DOUBLE) + + if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) } + return (dval) +end + + +# IP_AGETB -- Get an array of bytes from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetb (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +pointer sp, buf +int fp, nval, nstat +int ip_lnote(), read() + +begin + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + nval = len + else + nval = len + 1 + + call smark (sp) + call salloc (buf, nval, TY_CHAR) + + if (ptr == NULL) + call malloc (ptr, nval * SZB_CHAR, TY_CHAR) + nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1) + + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, nval) + call achtbc (Memc[buf], Memc[ptr], len) + + call sfree (sp) +end + + +# IP_AGETU -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetu (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +begin + call ip_agets (fd, ptr, len) + call achtsu (Mems[ptr], Mems[ptr], len) +end + + +# IP_AGET[silrd] -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + + +procedure ip_agets (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_SHORT) + nstat = read (fd, Mems[ptr], len * SZ_SHORT) +end + + +procedure ip_ageti (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_INT) + nstat = read (fd, Memi[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Memi[ptr], Memi[ptr], len) +end + + +procedure ip_agetl (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_LONG) + nstat = read (fd, Meml[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Meml[ptr], Meml[ptr], len) +end + + +procedure ip_agetr (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) + call ieevupkr (Memr[ptr], Memr[ptr], len) +end + + +procedure ip_agetd (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) + call ieevupkd (Memd[ptr], Memd[ptr], len) +end + + + +# IP_AGETN -- Get an array of native floats from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetn (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) +end + + +# IP_AGETN8 -- Get an array of native doubles from the file. The data pointer +# is allocated if necessary and contains the data on output. + +procedure ip_agetn8 (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) +end + + +# ----------------------------------------------------------------- +# ------------------ UTILITY FILE I/O FUNCTIONS ------------------- +# ----------------------------------------------------------------- + + +define BLKSIZE 1024 + +# IP_LINE -- Return the offset of the start of the given line number. + +int procedure ip_line (fd, line) + +int fd #i input file descriptor +int line #i line number to search + +pointer sp, cbuf, buf +int nl, offset, i, nread, fsize + +int read(), fstati() + +define done_ 99 +define err_ 98 + +begin + if (line == 1) { + return (1) + } else { + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + # Rewind file descriptor + call ip_lseek (fd, BOF) + nl = 1 + offset = 1 + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + do i = 1, BLKSIZE { + if (Memc[cbuf+i-1] == '\n') { + nl = nl + 1 + offset = offset + 1 + if (nl == line) + goto done_ + } else + offset = offset + 1 + if (offset >= fsize) + goto err_ + } + } +err_ call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) } + call sfree (sp) + call ip_lseek (fd, offset) + return (offset) + } +end + + +# IP_LOCATE -- Return the offset of the start of the given pattern. + +int procedure ip_locate (fd, offset, pattern) + +int fd #i input file descriptor +int offset #i offset to begin search +char pattern[ARB] #i pattern to locate + +pointer sp, cbuf, buf +int fsize, nread, patlen, cur_offset, loc + +int fstati(), read(), strsearch(), strlen() + +define done_ 99 + +begin + # Rewind file descriptor + call ip_lseek (fd, offset) + cur_offset = offset + + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)} + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + patlen = strlen (pattern) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + loc = strsearch (Memc[cbuf], pattern) + if (loc != 0) { + cur_offset = cur_offset + loc - 1 - patlen + goto done_ + } else { + # Allow some overlap in case the pattern broke over the blocks. + cur_offset = cur_offset + BLKSIZE - 2 * patlen + call ip_lseek (fd, cur_offset) + if (cur_offset + BLKSIZE > fsize) + nread = fsize - cur_offset + 1 + } + } + call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)} + call sfree (sp) + call ip_lseek (fd, offset) + return (cur_offset) +end + + +# IP_LSEEK -- Set the file position as a byte offset. + +procedure ip_lseek (fd, offset) + +int fd #i file descriptor +int offset #i requested offset + +long cur_offset, where, fsize +int fstati() +common /fiocom/ cur_offset + +begin + if (offset == BOF || offset == ERR) { + cur_offset = 1 + call seek (fd, BOF) + } else { + fsize = fstati (fd, F_FILESIZE) * SZB_CHAR + cur_offset = min (fsize, offset) + where = min (fsize, (offset/SZB_CHAR+mod(offset,2))) + call seek (fd, where) + } +end + + +# IP_LNOTE -- Note the file position as a byte offset. + +int procedure ip_lnote (fd) + +int fd #i file descriptor (unused) + +long cur_offset +common /fiocom/ cur_offset + +begin + return (cur_offset) +end + + +# IP_LSKIP -- Bump the file position by a byte offset. + +procedure ip_lskip (fd, skip) + +int fd #i file descriptor +int skip + +long cur_offset +common /fiocom/ cur_offset + +begin + call ip_lseek (fd, cur_offset+skip) +end diff --git a/pkg/dataio/import/generic/ipobands.x b/pkg/dataio/import/generic/ipobands.x new file mode 100644 index 00000000..65c6c1c4 --- /dev/null +++ b/pkg/dataio/import/generic/ipobands.x @@ -0,0 +1,375 @@ +include <error.h> +include <mach.h> +include <evvexpr.h> +include <fset.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false +define VDEBUG false + + +# IP_GETOP -- Called by evvexpr to get an operand. + +procedure ip_getop (ip, opname, o) + +pointer ip #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype +pointer sp, buf +pointer op + +int fstati(), ip_ptype(), strlen(), strncmp() +bool streq() + +begin + # First see if it's one of the special file operands. + if (opname[1] == '$') { + if (strncmp(opname, "$FSIZE", 3) == 0) { + O_LEN(o) = 0 + O_TYPE(o) = TY_INT + O_VALI(o) = fstati (IP_FD(ip), F_FILESIZE) * SZB_CHAR + } else if (strncmp(opname, "$FNAME", 3) == 0) { + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call fstats (IP_FD(ip), F_FILENAME, Memc[buf], SZ_FNAME) + + O_TYPE(o) = TY_CHAR + O_LEN(o) = strlen (Memc[buf]) + 1 + call malloc (O_VALP(o), O_LEN(o), TY_CHAR) + call strcpy (Memc[buf], O_VALC(o), i) + call sfree (sp) + } + + return + } + + nops = IP_NPIXT(ip) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = PTYPE(ip,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG) { + call eprintf ("getop: opname=%s tag=%s found=%d ") + call pargstr(opname) ; call pargstr(Memc[IO_TAG(op)]) + call pargi(found) + if (found == YES) call zzi_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + optype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + + case TY_INT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), IO_NPIX(op), TY_INT) + call amovi (Memi[IO_DATA(op)], Memi[O_VALP(o)], IO_NPIX(op)) + + case TY_LONG: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), IO_NPIX(op), TY_LONG) + call amovl (Meml[IO_DATA(op)], Meml[O_VALP(o)], IO_NPIX(op)) + + case TY_REAL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), IO_NPIX(op), TY_REAL) + call amovr (Memr[IO_DATA(op)], Memr[O_VALP(o)], IO_NPIX(op)) + + case TY_DOUBLE: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), IO_NPIX(op), TY_DOUBLE) + call amovd (Memd[IO_DATA(op)], Memd[O_VALP(o)], IO_NPIX(op)) + + } + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call sfree (sp) + call error (1, Memc[buf]) + } +end + + +# IP_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ip_evaluate (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ip_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_obfcn), ip, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# IP_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ip_obfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray, color, cmap +int i, len, v_nargs, func + +int or(), strdic() +bool strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case FLIPX, FLIPY: + v_nargs = 1 + case RED, GREEN, BLUE: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zzi_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + + case TY_INT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memi[r+i] + + G_COEFF * Memi[g+i] + + B_COEFF * Memi[b+i] + } + + case TY_LONG: + do i = 0, len { + Memr[gray+i] = R_COEFF * Meml[r+i] + + G_COEFF * Meml[g+i] + + B_COEFF * Meml[b+i] + } + + case TY_REAL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memr[r+i] + + G_COEFF * Memr[g+i] + + B_COEFF * Memr[b+i] + } + + case TY_DOUBLE: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memd[r+i] + + G_COEFF * Memd[g+i] + + B_COEFF * Memd[b+i] + } + + } + + case RED: + # Get the red colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + r = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mems[r+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Memi[r+i]+1) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Meml[r+i]+1) + + } + + case GREEN: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + g = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,Mems[g+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Memi[g+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Meml[g+i]+1)) + + } + + case BLUE: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + b = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,Mems[b+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Memi[b+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Meml[b+i]+1)) + + } + + case FLIPX: + # Set flag to reverse pixel order on output. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_X) + goto setop_ + + case FLIPY: + # Set flag to write image from bottom to top. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + + # Copy argument operand descriptor to 'o' +setop_ switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), O_LEN(args[1]), TY_SHORT) + call amovs (Mems[O_VALP(ARGS[1])], Mems[O_VALP(o)], O_LEN(o)) + + case TY_INT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), O_LEN(args[1]), TY_INT) + call amovi (Memi[O_VALP(args[1])], Memi[O_VALP(o)], O_LEN(o)) + + case TY_LONG: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), O_LEN(args[1]), TY_LONG) + call amovl (Meml[O_VALP(args[1])], Meml[O_VALP(o)], O_LEN(o)) + + case TY_REAL: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), O_LEN(args[1]), TY_REAL) + call amovr (Memr[O_VALP(args[1])], Memr[O_VALP(o)], O_LEN(o)) + + case TY_DOUBLE: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), O_LEN(args[1]), TY_DOUBLE) + call amovd (Memd[O_VALP(args[1])], Memd[O_VALP(o)], O_LEN(o)) + + } + + } + + if (DEBUG) { call zzi_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/import/generic/ipproc.x b/pkg/dataio/import/generic/ipproc.x new file mode 100644 index 00000000..def48b1c --- /dev/null +++ b/pkg/dataio/import/generic/ipproc.x @@ -0,0 +1,921 @@ +include <mach.h> +include <imhdr.h> +include <evvexpr.h> +include "../import.h" + +define DEBUG false + + +# IP_PRBAND -- Process a band interleaved file. + +procedure ip_prband (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix +int optype, nbytes_pix, percent +int cur_offset, band_offset, line_offset + +int ip_ptype() +long ip_lnote() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + # Compute the offset between the same pixel in different bands. This + # is the area of the image plus any image padding, computed as a + # byte offset. + optype = ip_ptype (IO_TYPE(PTYPE(ip,1)),IO_NBYTES(PTYPE(ip,1))) + switch (optype) { + case TY_UBYTE: nbytes_pix = 1 + case TY_USHORT, TY_SHORT: nbytes_pix = SZB_CHAR * SZ_SHORT + case TY_INT: nbytes_pix = SZB_CHAR * SZ_INT32 + case TY_LONG: nbytes_pix = SZB_CHAR * SZ_LONG + case TY_REAL: nbytes_pix = SZB_CHAR * SZ_REAL + case TY_DOUBLE: nbytes_pix = SZB_CHAR * SZ_DOUBLE + } + band_offset = (IP_AXLEN(ip,1) * (IP_AXLEN(ip,2)-1)) + + ((IP_LSKIP(ip) + IP_LPAD(ip)) * (IP_AXLEN(ip,2)-1)) + + IP_BSKIP(ip) + band_offset = (band_offset * nbytes_pix) #+ 1 + + if (DEBUG) { + call eprintf ("ip_prband: band_offset=%d curpos=%d\n") + call pargi(band_offset) ; call pargi(ip_lnote(fd)) + call zzi_prstruct ("ip_prband", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + # Skip pixels at front of line + line_offset = ip_lnote (fd) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, 1, npix, cmap) + + # Skip pixels at end of line. + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + cur_offset = ip_lnote (fd) + + # Loop over each of the remaining pixtypes. + do j = 2, IP_NPIXT(ip) { + # Seek to offset of next band (i.e. line_offset + band_offset). + call ip_lskip (fd, band_offset) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + call ip_rdline (ip, fd, j, npix, cmap) # read pixels in the line + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + + # Restore file pointer to cur_offset. + call ip_lseek (fd, cur_offset) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRLINE -- Process a line interleaved file. + +procedure ip_prline (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix, percent + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { + call eprintf ("ip_prline:\n") + call zzi_prstruct ("ip_prline", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + + do j = 1, IP_NPIXT(ip) { + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, j, npix, cmap) + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRPIX -- Process a pixel interleaved file. + +procedure ip_prpix (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +pointer op, data +int i, swap, optype, nlines +int percent, npix, totpix + +int and(), ip_ptype() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { call eprintf ("ip_prpix: ") } + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = IP_AXLEN(ip,1) + nlines = IP_NPIXT(ip) + do i = 1, nlines { + op = PTYPE(ip,i) + optype = ip_ptype (IO_TYPE(op),IO_NBYTES(op)) + IO_NPIX(op) = npix + if (IO_DATA(op) == NULL) + if (optype == TY_UBYTE) + call malloc (IO_DATA(op), npix, TY_SHORT) + else + call malloc (IO_DATA(op), npix, optype) + } + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + totpix = npix * IP_NPIXT(ip) + swap = IP_SWAP(ip) + percent = 0 + if (DEBUG) { + call zzi_prstruct ("ip_prpix", ip) + call eprintf ("nl=%d np=%d tp=%d:\n") + call pargi(nlines) ; call pargi(npix) ; call pargi(totpix) + } + do i = 1, nlines { + + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line. + switch (optype) { + case TY_UBYTE: + call ip_agetb (fd, data, totpix) + call ip_lskip (fd, totpix) + # Apply a colormap to the bytes. In general a pixel-interleaved + # file is a 24-bit True Color image, but maybe this is a + # 3-D color index file? + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], totpix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + + case TY_SHORT: + call ip_agets (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + case TY_INT: + call ip_ageti (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], totpix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_LONG: + call ip_agetl (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], totpix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_REAL: + call ip_agetr (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (totpix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_REAL))) + + case TY_DOUBLE: + call ip_agetd (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (totpix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_DOUBLE))) + + } + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + + if (optype == TY_UBYTE) + call mfree (data, TY_SHORT) + else + call mfree (data, optype) + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PROBEXPR -- Process each of the outbands expressions and write the result +# to the output image. + +procedure ip_probexpr (ip, im, npix, line) + +pointer ip #i task struct pointer +pointer im #i output image pointer +int npix #i number of output pixels +int line #i line number + +int i +pointer out, ip_evaluate() + +begin + # Loop over outbands expressions. + do i = 1, IP_NBANDS(ip) { + # Evaluate outbands expression. + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) + call ip_wrline (ip, im, out, npix, line, i) + + call evvfree (out) + } +end + + +# IP_RDLINE -- Read a line of pixels from the binary file. + +procedure ip_rdline (ip, fd, pnum, npix, cmap) + +pointer ip #i task struct pointer +int fd #i input file descriptor +int pnum #i pixtype number +int npix #i number of pixels to read +pointer cmap #i colormap pointer + +pointer op, data +int swap, ptype + +int and(), ip_ptype() + +begin + # Read pixels in the line and save as operand. + op = PTYPE(ip,pnum) + ptype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + data = IO_DATA(op) + swap = IP_SWAP(ip) + IO_NPIX(op) = npix + + switch (ptype) { + case TY_UBYTE: + call ip_agetb (fd, data, npix) + call ip_lskip (fd, npix) + # Apply a colormap to the bytes. If the colormap is non-null we + # assume the bytes are color indices into a colormap. + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], npix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (npix * (SZB_CHAR * SZ_SHORT))) + + case TY_SHORT: + call ip_agets (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_SHORT)) + + case TY_INT: + call ip_ageti (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], npix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_LONG: + call ip_agetl (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], npix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_LONG*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_REAL: + call ip_agetr (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (npix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_REAL)) + + case TY_DOUBLE: + call ip_agetd (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (npix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_DOUBLE)) + + } + IO_DATA(op) = data +end + + +# IP_WRLINE -- Write a line of pixels to the output image. We handle image +# flipping here to avoid possibly doing it several times while the outbands +# expression is being evaluated. + +procedure ip_wrline (ip, im, out, npix, line, band) + +pointer ip #i task struct pointer +pointer im #i output image pointer +pointer out #i output operand pointer +int npix #i number of pixels to read +int line #i image line number +int band #i image band number + +int i, lnum, type +int nldone, blnum +pointer sp, dptr, data, optr +bool lastline + +int and() +pointer imps3s(), imps3i(), imps3l(), imps3r(), imps3d() +pointer ip_chtype() + +data blnum /0/ +data nldone /1/ +data lastline /false/ + +begin + call smark (sp) + + # The first thing we do is change the datatype of the operand to + # match the output pixel type. + if (IP_OUTTYPE(ip) != NULL) { + if (IP_OUTTYPE(ip) == O_TYPE(out)) + optr = O_VALP(out) + else + optr = ip_chtype (out, IP_OUTTYPE(ip)) + } + type = IP_OUTTYPE(ip) + + # See if we're flipping image in Y, and adjust the line number. + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + lnum = IP_AXLEN(ip,2) - line + 1 + if (band == 1) + blnum = IP_SZBUF(ip) - mod (line-1, IP_SZBUF(ip)) + lastline = (lnum == 1) + } else { + lnum = line + if (band == 1) + blnum = blnum + 1 + lastline = (lnum == IP_AXLEN(ip,2)) + } + + # See if we're flipping image in x, and reverse the pixels. + if (and(IP_FLIP(ip),FLIP_X) == FLIP_X) { + call salloc (dptr, npix, type) + do i = 1, npix { + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[dptr+i-1] = Mems[optr+(npix-i)] + + case TY_INT: + Memi[dptr+i-1] = Memi[optr+(npix-i)] + + case TY_LONG: + Meml[dptr+i-1] = Meml[optr+(npix-i)] + + case TY_REAL: + Memr[dptr+i-1] = Memr[optr+(npix-i)] + + case TY_DOUBLE: + Memd[dptr+i-1] = Memd[optr+(npix-i)] + + } + } + } else + dptr = optr + + # Make sure the image pixtype is set. + if (IM_PIXTYPE(im) == NULL) + IM_PIXTYPE(im) = type + + # Allocate the buffer pointer if needed. + if (BUFFER(ip,band) == NULL) + call calloc (BUFFER(ip,band), npix*IP_SZBUF(ip), IP_OUTTYPE(ip)) + + if (nldone < IP_SZBUF(ip) && !lastline) { + # Copy the image line to the buffer + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + + } + if (band == IP_NBANDS(ip)) + nldone = nldone + 1 + + } else { + # Write the buffer to the image as a section. + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3s (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovs (Mems[BUFFER(ip,band)+(blnum-1)*npix], + Mems[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3s (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovs (Mems[BUFFER(ip,band)], Mems[data], npix*blnum) + } + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3i (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovi (Memi[BUFFER(ip,band)+(blnum-1)*npix], + Memi[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3i (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovi (Memi[BUFFER(ip,band)], Memi[data], + npix*blnum) + } + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3l (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovl (Meml[BUFFER(ip,band)+(blnum-1)*npix], + Meml[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3l (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovl (Meml[BUFFER(ip,band)], Meml[data], + npix*blnum) + } + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3r (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovr (Memr[BUFFER(ip,band)+(blnum-1)*npix], + Memr[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3r (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovr (Memr[BUFFER(ip,band)], Memr[data], + npix*blnum) + } + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3d (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovd (Memd[BUFFER(ip,band)+(blnum-1)*npix], + Memd[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3d (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovd (Memd[BUFFER(ip,band)], Memd[data], + npix*blnum) + } + + } + if (band == IP_NBANDS(ip)) { + nldone = 1 + blnum = 0 + } + } + + if (IP_OUTTYPE(ip) != O_TYPE(out)) + call mfree (optr, type) + call sfree (sp) +end + + +# IP_UPKPIX -- Unpack a line of pixel-interleaved pixels to the separate +# pixtype operand arrays. + +procedure ip_upkpix (ip, ptr, npix) + +pointer ip #i task struct pointer +pointer ptr #i pointer to pixels +int npix #i number of pixels in line + +pointer op[IM_MAXDIM] +int i, j, np, optype[IM_MAXDIM] + +int ip_ptype() + +begin + np = IP_NPIXT(ip) + do j = 1, np { + op[j] = PTYPE(ip,j) + optype[j] = ip_ptype (IO_TYPE(op[j]),IO_NBYTES(op[j])) + } + + do j = 1, np { + + do i = 0, npix-1 { + switch (optype[j]) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[IO_DATA(op[j])+i] = Mems[ptr+(i*np+j)-1] + + case TY_INT: + Memi[IO_DATA(op[j])+i] = Memi[ptr+(i*np+j)-1] + + case TY_LONG: + Meml[IO_DATA(op[j])+i] = Meml[ptr+(i*np+j)-1] + + case TY_REAL: + Memr[IO_DATA(op[j])+i] = Memr[ptr+(i*np+j)-1] + + case TY_DOUBLE: + Memd[IO_DATA(op[j])+i] = Memd[ptr+(i*np+j)-1] + + } + } + } +end + + +# IP_FIX_PIXTYPE -- Create the pixtype operands for 3-D band or line- +# interleaved files. These weren't allocated at first since the pixtype +# parameter or database field was atomic. + +procedure ip_fix_pixtype (ip) + +pointer ip #i task struct pointer + +pointer op, op1 +int i, nnp + +begin + if (DEBUG) { + call eprintf ("fix_pixtype: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # See if there's anything to be fixed. + if (IP_NDIM(ip) < 3 || IP_NDIM(ip) < IP_NPIXT(ip)) + return + if (BAND_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_NDIM(ip))) + return + if (LINE_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_INTERLEAVE(ip))) + return + + if (LINE_INTERLEAVED(ip)) + nnp = IP_INTERLEAVE(ip) + else + #nnp = IP_NDIM(ip) + nnp = IP_AXLEN(ip,3) + + # Make the new pixtype operands. + op1 = PTYPE(ip,1) + do i = 2, nnp { + call ip_alloc_operand (PTYPE(ip,i)) + op = PTYPE(ip,i) + IO_TYPE(op) = IO_TYPE(op1) + IO_NBYTES(op) = IO_NBYTES(op1) + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (i) + } + IP_NPIXT(ip) = nnp + + if (DEBUG) { call zzi_prstruct ("fix_pixtype", ip) } +end + + +# IP_FIX_OUTBANDS -- Create the outbands operands if none were specified in +# the parameter file. + +procedure ip_fix_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, buf +pointer im +int i, nbands + +define SZ_OBSTR 2500 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + if (DEBUG) { + call eprintf ("fix_outbands: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # Free up the existing outbands operands. + nbands = IP_NBANDS(ip) + do i = 1, nbands + call ip_free_outbands (OBANDS(ip,i)) + + # Create an outbands parameter string according to the tags in the + # pixtype structure. This way we preserve any user-defined tags on + # output. + nbands = IP_NPIXT(ip) + call aclrc (Memc[buf], SZ_FNAME) + do i = 1, nbands { + call ip_alloc_outbands (OBANDS(ip,i)) + call aclrc (Memc[buf], SZ_FNAME) + call sprintf (Memc[buf], SZ_FNAME, "b%d") + call pargi (i) + call strcpy (Memc[buf], O_EXPR(ip,i), SZ_EXPR) + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,i)), SZ_EXPR) + } + IP_NBANDS(ip) = nbands + + # Fix the output image dimensions. + im = IP_IM(ip) + IM_LEN(im,3) = IP_AXLEN(ip,3) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + + call sfree (sp) + + if (DEBUG) { call zzi_prstruct ("fix_outbands", ip) } +end + + +# IP_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. + +pointer procedure ip_chtype (op, type) + +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # Change the pixel type. + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + default: + call error (0, "Invalid output type requested.") + } + + out = coerce (out, TY_CHAR, type) + return (out) +end + + +define NTYPES 6 +define NBITPIX 4 + +# IP_PTYPE -- For a given pixtype parameter return the corresponding IRAF +# data type. + +int procedure ip_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + if (ptype == 0) + call error (0, "Invalid pixtype specified.") + else + return (ptype) +end + + +# IP_PSTAT - Print information about the progress we're making. + +procedure ip_pstat (ip, row, percent) + +pointer ip #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / IP_AXLEN(ip,2) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/import/generic/mkpkg b/pkg/dataio/import/generic/mkpkg new file mode 100644 index 00000000..9e8721db --- /dev/null +++ b/pkg/dataio/import/generic/mkpkg @@ -0,0 +1,15 @@ +# Compile the generic sources. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ipdb.x ../import.h ../ipfcn.h \ + <error.h> <evvexpr.h> <imhdr.h> <mach.h> + ipfio.x ../import.h <fset.h> <mach.h> + ipobands.x ../import.h ../ipfcn.h <error.h> <evvexpr.h> \ + <fset.h> <mach.h> + ipproc.x ../import.h <evvexpr.h> <imhdr.h> <mach.h> + ; |