Thread: [R-gregmisc-users] SF.net SVN: r-gregmisc: [1124] trunk/SASxport/src
Brought to you by:
warnes
Menu
▾
▴
r-gregmisc-users
|
From: <wa...@us...> - 2007-08-08 18:54:22
|
Revision: 1124
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1124&view=rev
Author: warnes
Date: 2007-08-08 11:54:00 -0700 (Wed, 08 Aug 2007)
Log Message:
-----------
Updates
Modified Paths:
--------------
trunk/SASxport/src/init.c
Removed Paths:
-------------
trunk/SASxport/src/SASxport.c
trunk/SASxport/src/SASxport.h
trunk/SASxport/src/foreign.h
Deleted: trunk/SASxport/src/SASxport.c
===================================================================
--- trunk/SASxport/src/SASxport.c 2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/SASxport.c 2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,649 +0,0 @@
-/*
- *
- * Read SAS transport data set format
- *
- * Copyright 1999-1999 Douglas M. Bates <ba...@st...>,
- * Saikat DebRoy <sa...@st...>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be
- * useful, but WITHOUT ANY WARRANTY; without even the implied
- * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU General Public License for more
- * details.
- *
- * You should have received a copy of the GNU General Public
- * License along with this program; if not, write to the Free
- * Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301 USA
- *
- */
-
-#include <stdio.h>
-#include <string.h>
-#include <R.h>
-#include <Rinternals.h>
-#include "foreign.h"
-#include "SASxport.h"
-
-#define HEADER_BEG "HEADER RECORD*******"
-#define HEADER_TYPE_LIBRARY "LIBRARY "
-#define HEADER_TYPE_MEMBER "MEMBER "
-#define HEADER_TYPE_DSCRPTR "DSCRPTR "
-#define HEADER_TYPE_NAMESTR "NAMESTR "
-#define HEADER_TYPE_OBS "OBS "
-#define HEADER_END "HEADER RECORD!!!!!!!000000000000000000000000000000 "
-
-#define LIB_HEADER HEADER_BEG HEADER_TYPE_LIBRARY HEADER_END
-#define MEM_HEADER HEADER_BEG HEADER_TYPE_MEMBER \
- "HEADER RECORD!!!!!!!000000000000000001600000000"
-#define DSC_HEADER HEADER_BEG HEADER_TYPE_DSCRPTR HEADER_END
-#define NAM_HEADER HEADER_BEG HEADER_TYPE_NAMESTR \
- "HEADER RECORD!!!!!!!000000"
-#define OBS_HEADER HEADER_BEG HEADER_TYPE_OBS HEADER_END
-#define BLANK24 " "
-
-#define GET_RECORD(rec, fp, len) \
- fread((rec), sizeof(char), (size_t) (len), (fp))
-
-#define IS_SASNA_CHAR(c) ((c) == 0x5f || (c) == 0x2e || \
- (0x41 <= (c) && (c) <= 0x5a))
-
-#ifndef NULL
-#define NULL ((void *) 0)
-#endif
-
-
-#define Two32 4294967296.0
-
-static double get_IBM_double(char* c, size_t len)
-{
- /* Conversion from IBM 360 format to double */
-/*
- * IBM format:
- * 6 5 0
- * 3 1 0
- *
- * SEEEEEEEMMMM ......... MMMM
- *
- * Sign bit, 7 bit exponent, 56 bit fraction. Exponent is
- * excess 64. The fraction is multiplied by a power of 16 of
- * the actual exponent. Normalized floating point numbers are
- * represented with the radix point immediately to the left of
- * the high order hex fraction digit.
- */
- unsigned int i, upper, lower;
- /* exponent is expressed here as
- excess 70 (=64+6) to accomodate
- integer conversion of c[1] to c[4] */
- char negative = c[0] & 0x80, exponent = (c[0] & 0x7f) - 70, buf[4];
- double value;
- char ibuf[8];
-
- if (len < 2 || len > 8)
- error(_("invalid field length in numeric variable"));
-
- /* this effectively zero-pads c: */
- memset(ibuf, 0, (size_t) 8);
- memcpy(ibuf, c, len);
- c = ibuf;
- /* check for missing value */
- /* This isn't really right: NAs are ' ', '.', A-Z plus zero fill */
- if (c[1] == '\0' && c[0] != '\0') return R_NaReal;
- /* convert c[1] to c[3] to an int */
- buf[0] = '\0';
- for (i = 1; i < 4; i++) buf[i] = c[i];
- char_to_uint(buf, upper);
- /* convert c[4] to c[7] to an int */
- for (i = 0; i < 4; i++) buf[i] = c[i + 4];
- char_to_uint(buf, lower);
- /* initialize the constant if needed */
- value = ((double) upper + ((double) lower)/Two32) *
- pow(16., (double) exponent);
- if (negative) value = -value;
- return value;
-}
-
-static int
-get_nam_header(FILE *fp, struct SAS_XPORT_namestr *namestr, int length)
-{
- char record[141];
- int n;
-
- record[length] = '\0';
- n = GET_RECORD(record, fp, length);
- if(n != length)
- return 0;
-
- char_to_short(record, namestr->ntype);
- char_to_short(record+2, namestr->nhfun);
- char_to_short(record+4, namestr->nlng);
- char_to_short(record+6, namestr->nvar0);
- memcpy(namestr->nname, record + 8, 8);
- memcpy(namestr->nlabel, record + 16, 40);
- memcpy(namestr->nform, record + 56, 8);
- char_to_short(record+64, namestr->nfl);
- char_to_short(record+66, namestr->nfd);
- char_to_short(record+68, namestr->nfj);
- memcpy(namestr->nfill, record + 70, 2);
- memcpy(namestr->niform, record + 72, 8);
- char_to_short(record+80, namestr->nifl);
- char_to_short(record+82, namestr->nifd);
- char_to_int(record+84, namestr->npos);
- return 1;
-}
-
-static int
-get_lib_header(FILE *fp, struct SAS_XPORT_header *head)
-{
- char record[81];
- int n;
-
- n = GET_RECORD(record, fp, 80);
- if(n == 80 && strncmp(LIB_HEADER, record, 80) != 0)
- error(_("file not in SAS transfer format"));
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80)
- return 0;
- record[80] = '\0';
- memcpy(head->sas_symbol[0], record, 8);
- memcpy(head->sas_symbol[1], record+8, 8);
- memcpy(head->saslib, record+16, 8);
- memcpy(head->sasver, record+24, 8);
- memcpy(head->sas_os, record+32, 8);
- if((strrchr(record+40, ' ') - record) != 63)
- return 0;
- memcpy(head->sas_create, record+64, 16);
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80)
- return 0;
- record[80] = '\0';
- memcpy(head->sas_mod, record, 16);
- if((strrchr(record+16, ' ') - record) != 79)
- return 0;
- return 1;
-}
-
-static int
-get_mem_header(FILE *fp, struct SAS_XPORT_member *member)
-{
- char record[81];
- int n;
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80 || strncmp(DSC_HEADER, record, 80) != 0)
- error(_("file not in SAS transfer format"));
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80)
- return 0;
- record[80] = '\0';
- memcpy(member->sas_symbol, record, 8);
- memcpy(member->sas_dsname, record+8, 8);
- memcpy(member->sasdata, record+16, 8);
- memcpy(member->sasver, record+24, 8);
- memcpy(member->sas_osname, record+32, 8);
- if((strrchr(record+40, ' ') - record) != 63)
- return 0;
- memcpy(member->sas_create, record+64, 16);
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80)
- return 0;
- memcpy(member->sas_mod, record, 16);
- if((strrchr(record+16, ' ') - record) != 79)
- return 0;
- return 1;
-}
-
-static int
-init_xport_info(FILE *fp)
-{
- char record[81];
- int n;
- int namestr_length;
-
- struct SAS_XPORT_header *lib_head;
-
- lib_head = Calloc(1, struct SAS_XPORT_header);
-
- if(!get_lib_header(fp, lib_head)) {
- Free(lib_head);
- error(_("SAS transfer file has incorrect library header"));
- }
-
- Free(lib_head);
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80 || strncmp(MEM_HEADER, record, 75) != 0 ||
- strncmp(" ", record+78, 2) != 0)
- error(_("file not in SAS transfer format"));
- record[78] = '\0';
- sscanf(record+75, "%d", &namestr_length);
-
- return namestr_length;
-}
-
-static int
-init_mem_info(FILE *fp, char *name)
-{
- int length, n;
- char record[81];
- char *tmp;
- struct SAS_XPORT_member *mem_head;
-
- mem_head = Calloc(1, struct SAS_XPORT_member);
- if(!get_mem_header(fp, mem_head)) {
- Free(mem_head);
- error(_("SAS transfer file has incorrect member header"));
- }
-
- n = GET_RECORD(record, fp, 80);
- record[80] = '\0';
- if(n != 80 || strncmp(NAM_HEADER, record, 54) != 0 ||
- (strrchr(record+58, ' ') - record) != 79) {
- Free(mem_head);
- error(_("file not in SAS transfer format"));
- }
- record[58] = '\0';
- sscanf(record+54, "%d", &length);
-
- tmp = strchr(mem_head->sas_dsname, ' ');
- n = tmp - mem_head->sas_dsname;
- if(n > 0) {
- if (n > 8)
- n = 8;
- strncpy(name, mem_head->sas_dsname, n);
- name[n] = '\0';
- } else name[0] = '\0';
-
- Free(mem_head);
-
- return length;
-}
-
-static int
-next_xport_info(FILE *fp, int namestr_length, int nvars, int *headpad,
- int *tailpad, int *length, int *ntype, int *nlng,
- int *nvar0, SEXP nname, SEXP nlabel, SEXP nform, int *npos)
-{
- char *tmp;
- char record[81];
- int i, n, nbytes, totwidth, nlength, restOfCard;
- struct SAS_XPORT_namestr *nam_head;
-
- nam_head = Calloc(nvars, struct SAS_XPORT_namestr);
-
- for(i = 0; i < nvars; i++) {
- if(!get_nam_header(fp, nam_head+i, namestr_length)) {
- Free(nam_head);
- error(_("SAS transfer file has incorrect library header"));
- }
- }
-
- *headpad = 480 + nvars * namestr_length;
- i = *headpad % 80;
- if(i > 0) {
- i = 80 - i;
- if (fseek(fp, i, SEEK_CUR) != 0) {
- Free(nam_head);
- error(_("file not in SAS transfer format"));
- }
- (*headpad) += i;
- }
-
- n = GET_RECORD(record, fp, 80);
- if(n != 80 || strncmp(OBS_HEADER, record, 80) != 0) {
- Free(nam_head);
- error(_("file not in SAS transfer format"));
- }
-
- for(i = 0; i < nvars; i++) {
- int nname_len = 0, nlabel_len = 0, nform_len = 0;
- char tmpname[41];
-
- ntype[i] = (int) ((nam_head[i].ntype == 1) ? REALSXP : STRSXP);
- nlng[i] = nam_head[i].nlng;
- nvar0[i] = nam_head[i].nvar0;
- npos[i] = nam_head[i].npos;
-
- /* Variable name */
- nname_len = 8;
- while (nname_len && nam_head[i].nname[nname_len-1] == ' ')
- nname_len--;
- strncpy(tmpname, nam_head[i].nname, nname_len);
- tmpname[nname_len] = '\0';
- SET_STRING_ELT(nname, i, mkChar(tmpname));
-
- /* Variable label */
- nlabel_len = 40;
- while (nlabel_len && nam_head[i].nlabel[nlabel_len-1] == ' ')
- nlabel_len--;
- strncpy(tmpname, nam_head[i].nlabel, nlabel_len);
- tmpname[nlabel_len] = '\0';
- SET_STRING_ELT(nlabel, i, mkChar(tmpname));
-
- /* Variable format name */
- nform_len = 8;
- while (nform_len && nam_head[i].nform[nform_len-1] == ' ')
- nform_len--;
- strncpy(tmpname, nam_head[i].nform, nform_len);
- tmpname[nform_len] = '\0';
- SET_STRING_ELT(nform, i, mkChar(tmpname));
- }
-
- Free(nam_head);
-
- totwidth = 0;
- for(i = 0; i < nvars; i++)
- totwidth += nlng[i];
-
- nbytes = 0;
- nlength = 0;
-/* tmp = (char *) R_alloc(totwidth+1, sizeof(char)); */
- tmp = CHAR(PROTECT(allocVector(CHARSXP, (totwidth<=80?81:(totwidth+1)) *
- sizeof(char))));
- restOfCard = 0;
- *tailpad = 0;
- while(!feof(fp)) {
- int allSpace = 1;
- fpos_t currentPos;
-
-/* restOfCard = 80 - (ftell(fp) % 80); */
- if (fgetpos(fp, ¤tPos)) {
- error(_("problem accessing SAS XPORT file"));
- }
-
- n = GET_RECORD(tmp, fp, restOfCard);
- if (n != restOfCard) {
- allSpace = 0;
- } else {
- for (i = 0; i < restOfCard; i++) {
- if (tmp[i] != ' ') {
- allSpace = 0;
- break;
- }
- }
- }
- if (allSpace) {
- n = GET_RECORD(record, fp, 80);
- if (n < 1) {
- *tailpad = restOfCard;
- break;
- }
- if(n == 80 && strncmp(MEM_HEADER, record, 75) == 0 &&
- strncmp(" ", record+78, 2) == 0) {
- *tailpad = restOfCard;
- record[78] = '\0';
- sscanf(record+75, "%d", &namestr_length);
- break;
- }
- }
- if (fsetpos(fp, ¤tPos)) {
- error(_("problem accessing SAS XPORT file"));
- }
-
- n = GET_RECORD(tmp, fp, totwidth);
- if (n != totwidth) {
- if (!feof(fp)) {
- error(_("problem accessing SAS XPORT file"));
- }
- *tailpad = n;
- break;
- }
- restOfCard = (restOfCard >= totwidth)?
- (restOfCard - totwidth):
- (80 - (totwidth - restOfCard)%80);
- nlength++;
- }
- *length = nlength;
- UNPROTECT(1);
-
- return (feof(fp)?-1:namestr_length);
-}
-
-/*
- * get the list element named str.
- */
-
-static SEXP
-getListElement(SEXP list, char *str) {
- SEXP names;
- SEXP elmt = (SEXP) NULL;
- char *tempChar;
- int i;
-
- names = getAttrib(list, R_NamesSymbol);
-
- for (i = 0; i < LENGTH(list); i++) {
- tempChar = CHAR(STRING_ELT(names, i));
- if( strcmp(tempChar,str) == 0) {
- elmt = VECTOR_ELT(list, i);
- break;
- }
- }
- return elmt;
-}
-
-#define VAR_INFO_LENGTH 11
-
-const char *cVarInfoNames[] = {
- "headpad",
- "type",
- "width",
- "index",
- "position",
- "name",
- "label",
- "format",
- "sexptype",
- "tailpad",
- "length"
-};
-
-#define XPORT_VAR_HEADPAD(varinfo) VECTOR_ELT(varinfo, 0)
-#define XPORT_VAR_TYPE(varinfo) VECTOR_ELT(varinfo, 1)
-#define XPORT_VAR_WIDTH(varinfo) VECTOR_ELT(varinfo, 2)
-#define XPORT_VAR_INDEX(varinfo) VECTOR_ELT(varinfo, 3)
-#define XPORT_VAR_POSITION(varinfo) VECTOR_ELT(varinfo, 4)
-#define XPORT_VAR_NAME(varinfo) VECTOR_ELT(varinfo, 5)
-#define XPORT_VAR_LABEL(varinfo) VECTOR_ELT(varinfo, 6)
-#define XPORT_VAR_FORM(varinfo) VECTOR_ELT(varinfo, 7)
-#define XPORT_VAR_SEXPTYPE(varinfo) VECTOR_ELT(varinfo, 8)
-#define XPORT_VAR_TAILPAD(varinfo) VECTOR_ELT(varinfo, 9)
-#define XPORT_VAR_LENGTH(varinfo) VECTOR_ELT(varinfo, 10)
-
-#define SET_XPORT_VAR_HEADPAD(varinfo, val) SET_VECTOR_ELT(varinfo, 0, val)
-#define SET_XPORT_VAR_TYPE(varinfo, val) SET_VECTOR_ELT(varinfo, 1, val)
-#define SET_XPORT_VAR_WIDTH(varinfo, val) SET_VECTOR_ELT(varinfo, 2, val)
-#define SET_XPORT_VAR_INDEX(varinfo, val) SET_VECTOR_ELT(varinfo, 3, val)
-#define SET_XPORT_VAR_POSITION(varinfo, val) SET_VECTOR_ELT(varinfo, 4, val)
-#define SET_XPORT_VAR_NAME(varinfo, val) SET_VECTOR_ELT(varinfo, 5, val)
-#define SET_XPORT_VAR_LABEL(varinfo, val) SET_VECTOR_ELT(varinfo, 6, val)
-#define SET_XPORT_VAR_FORM(varinfo, val) SET_VECTOR_ELT(varinfo, 7, val)
-#define SET_XPORT_VAR_SEXPTYPE(varinfo, val) SET_VECTOR_ELT(varinfo, 8, val)
-#define SET_XPORT_VAR_TAILPAD(varinfo, val) SET_VECTOR_ELT(varinfo, 9, val)
-#define SET_XPORT_VAR_LENGTH(varinfo, val) SET_VECTOR_ELT(varinfo, 10, val)
-
-SEXP
-xport_info(SEXP xportFile)
-{
- FILE *fp;
- int i, namestrLength, memLength, ansLength;
- char dsname[9];
- SEXP ans, ansNames, varInfoNames, varInfo;
- SEXP char_numeric, char_character;
-
- PROTECT(varInfoNames = allocVector(STRSXP, VAR_INFO_LENGTH));
- for(i = 0; i < VAR_INFO_LENGTH; i++)
- SET_STRING_ELT(varInfoNames, i, mkChar(cVarInfoNames[i]));
-
- PROTECT(char_numeric = mkChar("numeric"));
- PROTECT(char_character = mkChar("character"));
-
- if(!isValidString(xportFile))
- error(_("first argument must be a file name"));
- fp = fopen(R_ExpandFileName(CHAR(STRING_ELT(xportFile, 0))), "rb");
- if (!fp)
- error(_("unable to open file"));
- namestrLength = init_xport_info(fp);
-
- ansLength = 0;
- PROTECT(ans = allocVector(VECSXP, 0));
- PROTECT(ansNames = allocVector(STRSXP, 0));
-
- while(namestrLength > 0 && (memLength = init_mem_info(fp, dsname)) > 0) {
-
- PROTECT(varInfo = allocVector(VECSXP, VAR_INFO_LENGTH));
- setAttrib(varInfo, R_NamesSymbol, varInfoNames);
-
- SET_XPORT_VAR_TYPE(varInfo, allocVector(STRSXP, memLength));
- SET_XPORT_VAR_WIDTH(varInfo, allocVector(INTSXP, memLength));
- SET_XPORT_VAR_INDEX(varInfo, allocVector(INTSXP, memLength));
- SET_XPORT_VAR_POSITION(varInfo, allocVector(INTSXP, memLength));
- SET_XPORT_VAR_NAME(varInfo, allocVector(STRSXP, memLength));
- SET_XPORT_VAR_LABEL(varInfo, allocVector(STRSXP, memLength));
- SET_XPORT_VAR_FORM(varInfo, allocVector(STRSXP, memLength));
- SET_XPORT_VAR_SEXPTYPE(varInfo, allocVector(INTSXP, memLength));
- SET_XPORT_VAR_HEADPAD(varInfo, allocVector(INTSXP, 1));
- SET_XPORT_VAR_TAILPAD(varInfo, allocVector(INTSXP, 1));
- SET_XPORT_VAR_LENGTH(varInfo, allocVector(INTSXP, 1));
-
- namestrLength =
- next_xport_info(fp, namestrLength, memLength,
- INTEGER(XPORT_VAR_HEADPAD(varInfo)),
- INTEGER(XPORT_VAR_TAILPAD(varInfo)),
- INTEGER(XPORT_VAR_LENGTH(varInfo)),
- INTEGER(XPORT_VAR_SEXPTYPE(varInfo)),
- INTEGER(XPORT_VAR_WIDTH(varInfo)),
- INTEGER(XPORT_VAR_INDEX(varInfo)),
- XPORT_VAR_NAME(varInfo),
- XPORT_VAR_LABEL(varInfo),
- XPORT_VAR_FORM(varInfo),
- INTEGER(XPORT_VAR_POSITION(varInfo)));
-
- for(i = 0; i < memLength; i++) {
- int *ntype = INTEGER(XPORT_VAR_SEXPTYPE(varInfo));
- SET_STRING_ELT(XPORT_VAR_TYPE(varInfo), i,
- (ntype[i] == REALSXP) ? char_numeric :
- char_character);
- }
- PROTECT(ans = lengthgets(ans, ansLength+1));
- PROTECT(ansNames = lengthgets(ansNames, ansLength+1));
-/* PROTECT(newAns = allocVector(VECSXP, ansLength+1)); */
-/* PROTECT(newAnsNames = allocVector(STRSXP, ansLength+1)); */
-
-/* for(i = 0; i < ansLength; i++) { */
-/* SET_VECTOR_ELT(newAns, i, VECTOR_ELT(ans, i)); */
-/* SET_STRING_ELT(newAnsNames, i, STRING_ELT(ansNames, i)); */
-/* } */
-/* ans = newAns; */
-/* ansNames = newAnsNames; */
-
- SET_STRING_ELT(ansNames, ansLength, mkChar(dsname));
- SET_VECTOR_ELT(ans, ansLength, varInfo);
- ansLength++;
-
- UNPROTECT(5);
- PROTECT(ans);
- PROTECT(ansNames);
- }
-
- setAttrib(ans, R_NamesSymbol, ansNames);
- UNPROTECT(5);
- fclose(fp);
- return ans;
-}
-
-SEXP
-xport_read(SEXP xportFile, SEXP xportInfo)
-{
- int i, j, k, n;
- int nvar;
- int ansLength, dataLength, totalWidth;
- int dataHeadPad, dataTailPad;
- int *dataWidth;
- int *dataPosition;
- SEXPTYPE *dataType;
- char *record, *tmpchar, *c;
- FILE *fp;
- SEXP ans, names, data, dataInfo, dataName;
-
- ansLength = LENGTH(xportInfo);
- PROTECT(ans = allocVector(VECSXP, ansLength));
- names = getAttrib(xportInfo, R_NamesSymbol);
- setAttrib(ans, R_NamesSymbol, names);
-
- if(!isValidString(xportFile))
- error(_("first argument must be a file name"));
- fp = fopen(R_ExpandFileName(CHAR(STRING_ELT(xportFile, 0))), "rb");
- if (!fp)
- error(_("unable to open file"));
- if (fseek(fp, 240, SEEK_SET) != 0)
- error(_("problem reading SAS XPORT file '%s'"),
- CHAR(STRING_ELT(xportFile, 0)));
-
- for(i = 0; i < ansLength; i++) {
- dataInfo = VECTOR_ELT(xportInfo, i);
- dataName = getListElement(dataInfo, "name");
- nvar = LENGTH(dataName);
- dataLength = asInteger(getListElement(dataInfo, "length"));
- SET_VECTOR_ELT(ans, i, data = allocVector(VECSXP, nvar));
- setAttrib(data, R_NamesSymbol, dataName);
- dataType = (SEXPTYPE *) INTEGER(getListElement(dataInfo, "sexptype"));
- for(j = 0; j < nvar; j++)
- SET_VECTOR_ELT(data, j, allocVector(dataType[j], dataLength));
-
- dataWidth = INTEGER(getListElement(dataInfo, "width"));
- dataPosition = INTEGER(getListElement(dataInfo, "position"));
-
- totalWidth = 0;
- for(j = 0; j < nvar; j++)
- totalWidth += dataWidth[j];
-/* record = (char *) R_alloc(totalWidth + 1, sizeof (char)); */
- record = CHAR(PROTECT(allocVector(CHARSXP,
- (totalWidth+1) * sizeof(char))));
-
- dataHeadPad = asInteger(getListElement(dataInfo, "headpad"));
- dataTailPad = asInteger(getListElement(dataInfo, "tailpad"));
- fseek(fp, dataHeadPad, SEEK_CUR);
-
- for(j = 0; j < dataLength; j++) {
- n = GET_RECORD(record, fp, totalWidth);
- if(n != totalWidth) {
- error(_("problem reading SAS transport file"));
- }
-
- for(k = nvar-1; k >= 0; k--) {
- tmpchar = record + dataPosition[k];
- if(dataType[k] == REALSXP) {
- REAL(VECTOR_ELT(data, k))[j] =
- get_IBM_double(tmpchar, dataWidth[k]);
- } else {
- tmpchar[dataWidth[k]] = '\0';
- /* strip trailing blanks */
- c = tmpchar + dataWidth[k];
- while (c-- > tmpchar && *c == ' ')
- *c ='\0';
-
- SET_STRING_ELT(VECTOR_ELT(data, k), j,
- (c < tmpchar) ? R_BlankString :
- mkChar(tmpchar));
- }
- }
- }
-
- fseek(fp, dataTailPad, SEEK_CUR);
-
- UNPROTECT(1);
- }
- UNPROTECT(1);
- fclose(fp);
- return ans;
-}
Deleted: trunk/SASxport/src/SASxport.h
===================================================================
--- trunk/SASxport/src/SASxport.h 2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/SASxport.h 2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,77 +0,0 @@
-/*
- *
- * This file is derived from code in the SAS Technical Support
- * document TS-140 "The Record Layout of a Data Set in SAS Transport
- * (XPORT) Format" available as
- * http://ftp.sas.com/techsup/download/technote/ts140.html
- */
-
-#ifndef SASEXPORT_H
-#define SASEXPORT_H
-
-#include <string.h> /* for memcpy and memset */
-#include "foreign.h"
-#include "swap_bytes.h"
-
-/* double cnxptiee(double from, int fromtype, int totype); */
-
-
-
-struct SAS_XPORT_header {
- char sas_symbol[2][8]; /* should be "SAS " */
- char saslib[8]; /* should be "SASLIB " */
- char sasver[8];
- char sas_os[8];
- char sas_create[16];
- char sas_mod[16];
-};
-
-struct SAS_XPORT_member {
- char sas_symbol[8];
- char sas_dsname[8];
- char sasdata[8];
- char sasver[8];
- char sas_osname[8];
- char sas_create[16];
- char sas_mod[16];
-};
-
-struct SAS_XPORT_namestr {
- short ntype; /* VARIABLE TYPE: 1=NUMERIC, 2=CHAR */
- short nhfun; /* HASH OF NNAME (always 0) */
- short nlng; /* LENGTH OF VARIABLE IN OBSERVATION */
- short nvar0; /* VARNUM */
- char nname[8]; /* NAME OF VARIABLE */
- char nlabel[40]; /* LABEL OF VARIABLE */
- char nform[8]; /* NAME OF FORMAT */
- short nfl; /* FORMAT FIELD LENGTH OR 0 */
- short nfd; /* FORMAT NUMBER OF DECIMALS */
- short nfj; /* 0=LEFT JUSTIFICATION, 1=RIGHT JUST */
- char nfill[2]; /* (UNUSED, FOR ALIGNMENT AND FUTURE) */
- char niform[8]; /* NAME OF INPUT FORMAT */
- short nifl; /* INFORMAT LENGTH ATTRIBUTE */
- short nifd; /* INFORMAT NUMBER OF DECIMALS */
- int npos; /* POSITION OF VALUE IN OBSERVATION */
- char rest[52]; /* remaining fields are irrelevant */
-};
-
-#ifdef WORDS_BIGENDIAN
-
-#define char_to_short(from, to) memcpy(&to, from, 2)
-#define char_to_int(from, to) memcpy(&to, from, 4)
-#define char_to_uint(from, to) memcpy(&to, from, 4)
-
-#else
-
-#define char_to_short(from, to) memcpy(&to, from, 2); reverse_short(to);
-#define char_to_int(from, to) memcpy(&to, from, 4); reverse_int(to);
-#define char_to_uint(from, to) memcpy(&to, from, 4); reverse_uint(to);
-
-#endif /* WORDS_BIGENDIAN */
-
-
-SEXP xport_info(SEXP xportFile);
-SEXP xport_read(SEXP xportFile, SEXP xportInfo);
-
-
-#endif /* SASEXPORT_H */
Deleted: trunk/SASxport/src/foreign.h
===================================================================
--- trunk/SASxport/src/foreign.h 2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/foreign.h 2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,79 +0,0 @@
-/*
- *
- * Common header file for the foreign package for R
- *
- * Copyright 2000-2000 Saikat DebRoy <sa...@st...>
- * Douglas M. Bates <ba...@st...>,
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be
- * useful, but WITHOUT ANY WARRANTY; without even the implied
- * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU General Public License for more
- * details.
- *
- * You should have received a copy of the GNU General Public
- * License along with this program; if not, write to the Free
- * Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- * Boston, MA 02110-1301 USA
- *
- */
-
-#ifndef FOREIGN_H
-#define FOREIGN_H
-
-#include <R.h>
-#include <Rinternals.h>
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#define _(String) dgettext ("foreign", String)
-#define gettext_noop(String) (String)
-#else
-#define _(String) (String)
-#define gettext_noop(String) (String)
-#endif
-
-#define CN_TYPE_BIG 1
-#define CN_TYPE_LITTLE 2
-#define CN_TYPE_XPORT 3
-#define CN_TYPE_IEEEB CN_TYPE_BIG
-#define CN_TYPE_IEEEL CN_TYPE_LITTLE
-
-#define BIG 4321
-#define LITTLE 1234
-#define UNKNOWN 0000
-
-#ifdef WORDS_BIGENDIAN
-# define CN_TYPE_NATIVE CN_TYPE_IEEEB
-# define endian BIG
-#else
-# define CN_TYPE_NATIVE CN_TYPE_IEEEL
-# define endian LITTLE
-#endif /* not WORDS_BIGENDIAN */
-
-typedef int R_int32;
-/* typedef short int16; unused */
-
-typedef double R_flt64;
-/* typedef float flt32; unused */
-
-#define FPREP_IEEE754 754
-#define FPREP FPREP_IEEE754
-
-#ifdef max
-# undef max
-#endif
-#ifdef min
-# undef min
-#endif
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-
-extern char* R_ExpandFileName(char*);
-
-#endif /* FOREIGN_H */
Modified: trunk/SASxport/src/init.c
===================================================================
--- trunk/SASxport/src/init.c 2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/init.c 2007-08-08 18:54:00 UTC (rev 1124)
@@ -22,8 +22,8 @@
#include <Rinternals.h>
#include <R_ext/Rdynload.h>
#include "writeSAS.h"
-#include "foreign.h"
-#include "SASxport.h"
+//#include "foreign.h"
+//#include "SASxport.h"
#define ARGTYPE static R_NativePrimitiveArgType
@@ -54,8 +54,8 @@
#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
static const R_CallMethodDef CallEntries[] = {
- CALLDEF(xport_info, 1),
- CALLDEF(xport_read, 2),
+// CALLDEF(xport_info, 1),
+// CALLDEF(xport_read, 2),
CALLDEF(getRawBuffer, 0),
{NULL, NULL, 0}
};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-08-12 03:12:44
|
Revision: 1136
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1136&view=rev
Author: warnes
Date: 2007-08-11 20:12:21 -0700 (Sat, 11 Aug 2007)
Log Message:
-----------
1st attempt at rewriting cnxptiee.[ch]
Modified Paths:
--------------
trunk/SASxport/src/cnxptiee.h
trunk/SASxport/src/test_fields.c
trunk/SASxport/src/writeSAS.h
Added Paths:
-----------
trunk/SASxport/src/B8.h
trunk/SASxport/src/IEEEtoIBM.c
trunk/SASxport/src/MASKS.h
trunk/SASxport/src/main.c
trunk/SASxport/src/reverse.c
Added: trunk/SASxport/src/B8.h
===================================================================
--- trunk/SASxport/src/B8.h (rev 0)
+++ trunk/SASxport/src/B8.h 2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,60 @@
+/* Binary constant generator macro
+By Tom Torfs - donated to the public domain
+*/
+
+#include <sys/types.h>
+
+
+/* All macro's evaluate to compile-time constants */
+
+/* *** helper macros *** /
+
+/* turn a numeric literal into a hex constant
+(avoids problems with leading zeroes)
+8-bit constants max value 0x11111111, always fits in unsigned long
+*/
+#define HEX__(n) 0x##n##LU
+
+/* 8-bit conversion function */
+#define B8__(x) ((x&0x0000000FLU)?1:0) \
++((x&0x000000F0LU)?2:0) \
++((x&0x00000F00LU)?4:0) \
++((x&0x0000F000LU)?8:0) \
++((x&0x000F0000LU)?16:0) \
++((x&0x00F00000LU)?32:0) \
++((x&0x0F000000LU)?64:0) \
++((x&0xF0000000LU)?128:0)
+
+/* *** user macros *** /
+
+/* for upto 8-bit binary constants */
+#define B8(d) ((unsigned char)B8__(HEX__(d)))
+
+/* for upto 16-bit binary constants, MSB first */
+#define B16(dmsb,dlsb) (((unsigned short)B8(dmsb)<<8) \
++ B8(dlsb))
+
+/* for upto 32-bit binary constants, MSB first */
+#define B32(dmsb,db2,db3,dlsb) ( \
++ ((unsigned long)B8(dmsb)<<24) \
++ ((unsigned long)B8(db2)<<16) \
++ ((unsigned long)B8(db3)<<8) \
++ B8(dlsb))
+
+/* for upto 32-bit binary constants, MSB first */
+#define B64(dmsb,db2,db3,db4,db5,db6,db7,dlsb) ( \
++ ((unsigned int64_t)B8(dmsb<<56) \
++ ((unsigned int64_t)B8(db2)<<48) \
++ ((unsigned int64_t)B8(db3)<<40) \
++ ((unsigned int64_t)B8(db4 <<32) \
++ ((unsigned int64_t)B8(dm5)<<24) \
++ ((unsigned int64_t)B8(db6)<<16) \
++ ((unsigned int64_t)B8(db7)<<8 ) \
++ B8(dlsb))
+
+
+/* Sample usage:
+B8(01010101) = 85
+B16(10101010,01010101) = 43605
+B32(10000000,11111111,10101010,01010101) = 2164238933
+*/
Added: trunk/SASxport/src/IEEEtoIBM.c
===================================================================
--- trunk/SASxport/src/IEEEtoIBM.c (rev 0)
+++ trunk/SASxport/src/IEEEtoIBM.c 2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,109 @@
+//#include "writeSAS.h"
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import <assert.h>
+#import <sys/types.h>
+
+typedef struct { /* IBM floating point format */
+ unsigned sign : 1; /* Sign bit */
+ unsigned exponent: 7; /* Exponent */
+ //unsigned fraction: 56; /* Fraction */
+ unsigned fraction1: 24; /* Top half of fraction */
+ unsigned fraction2: 32; /* Lower half of fraction */
+} IBM_fp_struct;
+
+
+typedef struct { /* IEEE floating point format */
+ unsigned sign : 1; /* Sign bit */
+ unsigned exponent: 11; /* Exponent */
+ // unsigned fraction: 52; /* Fraction */
+ unsigned fraction1: 20; /* Top half of fraction */
+ unsigned fraction2: 32; /* Lower half of fraction */
+} IEEE_fp_struct;
+
+
+int IEEEtoIBM(double *ieee, double *ibm )
+{
+ IEEE_fp_struct *ieee_fp = (IEEE_fp_struct*) ieee;
+ IBM_fp_struct *ibm_fp = (IBM_fp_struct* ) ibm;
+ int64_t sign;
+ int64_t exponent;
+ int64_t fraction;
+ short low_exp_bits;
+
+ /*** Extract Pieces ***/
+ // Sign = Ieee & Ieee_Sign;
+ // Exponent = *Ieee & Ieee_Exp;
+ // Fraction = *Ieee & Ieee_Frac;
+
+ printf("1\n");
+
+ /*** copy IEEE sign to IBM sign ***/
+ ibm_fp->sign = ieee_fp->sign;
+
+ printf("2\n");
+
+ /*** convert IEEE exponent to IBM exponent ***/
+ exponent = ieee_fp->exponent;
+
+ printf("3\n");
+
+ /* store lowest 2 bits from exponent */
+ low_exp_bits = exponent % 16;
+
+
+ printf("4\n");
+
+ /* divide exponent by 4 to get from IEEE pow(2) exponent to IBM pow(16) exponent */
+ exponent = exponent >> 2;
+
+ printf("5\n");
+
+
+ /* put it into the return value */
+ ibm_fp->exponent = exponent;
+
+ printf("6\n");
+
+
+ /*** convert IEEE fraction to IBM fraction */
+ fraction = ((int64_t) ieee_fp->fraction1 ) << 32 | ((int64_t) ieee_fp->fraction2);
+
+ printf("7\n");
+
+
+ /* shift left by low order bits lost from exponent */
+ fraction = fraction << (low_exp_bits && 0x03);
+
+
+ printf("8\n");
+
+ /* add leading 1 bit */
+ fraction >> 1;
+ fraction = fraction | ( ((int64_t) 1) <<55 );
+
+ printf("9\n");
+
+
+ ibm_fp->fraction1 = (int32_t) (fraction >> 32) | 0x0FFFFF;
+ ibm_fp->fraction2 = (int32_t) fraction;
+
+
+ printf("10\n");
+
+
+ char *buf= (char*) ibm;
+ char tmp;
+ int i;
+ for(i=0; i<8; i++)
+ {
+ tmp = buf[7-i];
+ buf[7-i] = buf[i];
+ buf[i] = tmp;
+ }
+
+ return 0;
+}
+
Added: trunk/SASxport/src/MASKS.h
===================================================================
--- trunk/SASxport/src/MASKS.h (rev 0)
+++ trunk/SASxport/src/MASKS.h 2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,23 @@
+/* Masks for IBM fields */
+#define IBM_SIGN B64(10000000, 0000000, 0000000, 00000000, \
+ 00000000, 0000000, 0000000, 00000000)
+
+#define IBM_EXP B64(01111111, 0000000, 0000000, 00000000, \
+ 00000000, 0000000, 0000000, 00000000)
+
+#define IBM_FRAC B64(00000000, 1111111, 1111111, 11111111, \
+ 11111111, 1111111, 1111111, 11111111)
+
+#define IBM_FRAC_MSB B64(00000000, 1000000, 0000000, 00000000, \
+ 00000000, 0000000, 0000000, 00000000)
+
+/* Masks for IEEE fields */
+#define IEEE_SIGN B64(10000000, 0000000, 0000000, 00000000, \
+ 00000000, 0000000, 0000000, 00000000)
+
+#define IEEE_EXP B64(01111111, 1111000, 0000000, 00000000, \
+ 00000000, 0000000, 0000000, 00000000)
+
+#define IEEE_FRAC B64(00000000, 0000111, 1111111, 11111111, \
+ 11111111, 1111111, 1111111, 11111111)
+
Modified: trunk/SASxport/src/cnxptiee.h
===================================================================
--- trunk/SASxport/src/cnxptiee.h 2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/cnxptiee.h 2007-08-12 03:12:21 UTC (rev 1136)
@@ -23,13 +23,13 @@
int get_native();
#endif
-#ifdef BIG_ENDIAN
-#define REVERSE(a,b)
-#endif
+/* #ifdef BIG_ENDIAN */
+/* #define REVERSE(a,b) */
+/* #endif */
-#ifdef LITTLE_ENDIAN
-#define DEFINE_REVERSE
-void REVERSE();
-#endif
+/* #ifdef LITTLE_ENDIAN */
+/* #define DEFINE_REVERSE */
+/* void REVERSE(); */
+/* #endif */
#endif /* CNXPTIEE */
Added: trunk/SASxport/src/main.c
===================================================================
--- trunk/SASxport/src/main.c (rev 0)
+++ trunk/SASxport/src/main.c 2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,55 @@
+#include <math.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import <assert.h>
+#import <sys/types.h>
+
+
+extern int cnxptiee(char *from, int fromtype, char *to, int totype);
+int IEEEtoIBM(double *ieee, double *ibm );
+
+int main(int argc, char *argv)
+{
+ double ieee;
+ double ibm_sas, ieee_sas;
+ double ibm_our, ieee_our;
+ char *ibm_sas_c = (char*) &ibm_sas;
+ char *ibm_our_c = (char*) &ibm_our;
+
+
+ for(int i=0; i<10; i++)
+ {
+ ieee = pow(2.0, ((double) i)) + 1.0 + 1.0 / ( ((double) i) + 1.0);
+
+ /* from ieee to ibm, SAS code */
+ cnxptiee( (char*) &ieee, 0, (char*) &ibm_sas, 1 );
+
+ /* and back again, SAS code */
+ cnxptiee( (char*) &ibm_sas, 1, (char*) &ieee_sas, 0 );
+
+
+ /* from ieee to ibm, our code */
+ IEEEtoIBM( &ieee, &ibm_our );
+
+ /* and back again, SAS code */
+ cnxptiee( (char*) &ibm_our, 1, (char*) &ieee_our, 0 );
+
+
+ printf("i=%5d, ieee=%10f, ieee_sas=%10f ieee_our=%10f \n", i,
+ ieee, ieee_sas, ieee_our);
+
+ for(int index=0; index<8; index++)
+ {
+ printf(" ");
+ printf("%2x ", ibm_sas_c[index]);
+ printf("%2x ", ibm_our_c[index]);
+ printf("\n");
+ }
+ printf("\n");
+
+ }
+
+ return 0;
+}
+
Added: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c (rev 0)
+++ trunk/SASxport/src/reverse.c 2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,83 @@
+#include "writeSAS.h"
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import <assert.h>
+#import <sys/types.h>
+
+/* reverse: convert current byte order to little endian */
+void reverse( u_char *intp, size_t size)
+{
+ static u_char endianTest[2] = {0x01,0x00};
+ size_t i;
+ u_char tmp;
+
+#if !defined(BIG_ENDIAN) && !defined(LITTLE_ENDIAN)
+ /* Test if we are on a big endian or little endian platform */
+ if( (short) *endianTest == 1 )
+ {
+ /* Little Endian */
+ /* Do nothing */
+ return;
+ }
+#endif
+
+ /* Big Endian */
+ /* Swap bytes */
+ for(i=0; i < size/2; i++)
+ {
+ tmp = (u_char) intp[i];
+ intp[i] = intp[size-i-1];
+ intp[size-i] = tmp;
+ }
+
+ return;
+}
+
+
+/* test code */
+void test_reverse()
+{
+ u_char byte_pattern[1] = { 0x00 };
+ u_char byte_value = 0x00;
+
+ u_char short_pattern[2] = { 0x00, 0x01 }; /* NB: little endian byte pattern */
+ short short_value = 0x0100; /* NB: hex is written big endian */
+
+ u_char int_pattern[4] = { 0x0, 0x01, 0x02, 0x03 };
+ int int_value = 0x03020100;
+
+ u_char long_pattern[4] = { 0x0, 0x01, 0x02, 0x03 };
+ long long_value = 0x03020100;
+
+ /* Do the reverse, then test */
+
+ /* byte */
+ REVERSE( &byte_value, sizeof(u_char) );
+ assert( (u_char) *byte_pattern == byte_value );
+
+ /* short */
+ REVERSE( &short_value, sizeof(short) );
+ assert( *((short *) short_pattern) == short_value );
+
+ /* int */
+ REVERSE( &int_value, sizeof(int) );
+ assert( *((int *) int_pattern) == int_value );
+
+ /* long */
+ REVERSE( &long_value, sizeof(long) );
+ assert( *((long*) long_pattern) == long_value );
+
+}
+
+
+#ifdef DO_TEST
+int main(int argc, u_char *argv)
+{
+ test_reverse();
+}
+
+
+
+#endif
Modified: trunk/SASxport/src/test_fields.c
===================================================================
--- trunk/SASxport/src/test_fields.c 2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/test_fields.c 2007-08-12 03:12:21 UTC (rev 1136)
@@ -151,6 +151,8 @@
return 0;
}
+
+
void doTest()
{
/* small buffer */
@@ -167,5 +169,9 @@
test_blankCopy(BIG);
test_zeroCopy(BIG);
+
+
+ /* test reverse */
+ test_reverse();
}
Modified: trunk/SASxport/src/writeSAS.h
===================================================================
--- trunk/SASxport/src/writeSAS.h 2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/writeSAS.h 2007-08-12 03:12:21 UTC (rev 1136)
@@ -27,7 +27,9 @@
#include <R.h>
#include <Rinternals.h>
+#include <sys/types.h>
+
/*****
* Useful constants
*****/
@@ -35,6 +37,19 @@
#define MISSING 0x2e000000 /* Standard SAS missing value: '.' */
/*****
+ REVERSE macro, used as a wrapper for the reverse() function to avoid
+ compiling/calling it on little-endian.
+ *****/
+
+#ifdef BIG_ENDIAN
+# define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
+#elif defined(LITTLE_ENDIAN)
+# define REVERSE(a,b)
+#else
+# define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
+#endif
+
+/*****
* Useful macro functions
*****/
@@ -152,4 +167,7 @@
void doTest();
+void reverse( u_char *intp, size_t size);
+
+
#endif /* FIELDS_H */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-08-12 03:13:37
|
Revision: 1137
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1137&view=rev
Author: warnes
Date: 2007-08-11 20:13:36 -0700 (Sat, 11 Aug 2007)
Log Message:
-----------
Remove new stuff... use SAS's code instead
Removed Paths:
-------------
trunk/SASxport/src/B8.h
trunk/SASxport/src/IEEEtoIBM.c
trunk/SASxport/src/MASKS.h
trunk/SASxport/src/main.c
trunk/SASxport/src/reverse.c
Deleted: trunk/SASxport/src/B8.h
===================================================================
--- trunk/SASxport/src/B8.h 2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/B8.h 2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,60 +0,0 @@
-/* Binary constant generator macro
-By Tom Torfs - donated to the public domain
-*/
-
-#include <sys/types.h>
-
-
-/* All macro's evaluate to compile-time constants */
-
-/* *** helper macros *** /
-
-/* turn a numeric literal into a hex constant
-(avoids problems with leading zeroes)
-8-bit constants max value 0x11111111, always fits in unsigned long
-*/
-#define HEX__(n) 0x##n##LU
-
-/* 8-bit conversion function */
-#define B8__(x) ((x&0x0000000FLU)?1:0) \
-+((x&0x000000F0LU)?2:0) \
-+((x&0x00000F00LU)?4:0) \
-+((x&0x0000F000LU)?8:0) \
-+((x&0x000F0000LU)?16:0) \
-+((x&0x00F00000LU)?32:0) \
-+((x&0x0F000000LU)?64:0) \
-+((x&0xF0000000LU)?128:0)
-
-/* *** user macros *** /
-
-/* for upto 8-bit binary constants */
-#define B8(d) ((unsigned char)B8__(HEX__(d)))
-
-/* for upto 16-bit binary constants, MSB first */
-#define B16(dmsb,dlsb) (((unsigned short)B8(dmsb)<<8) \
-+ B8(dlsb))
-
-/* for upto 32-bit binary constants, MSB first */
-#define B32(dmsb,db2,db3,dlsb) ( \
-+ ((unsigned long)B8(dmsb)<<24) \
-+ ((unsigned long)B8(db2)<<16) \
-+ ((unsigned long)B8(db3)<<8) \
-+ B8(dlsb))
-
-/* for upto 32-bit binary constants, MSB first */
-#define B64(dmsb,db2,db3,db4,db5,db6,db7,dlsb) ( \
-+ ((unsigned int64_t)B8(dmsb<<56) \
-+ ((unsigned int64_t)B8(db2)<<48) \
-+ ((unsigned int64_t)B8(db3)<<40) \
-+ ((unsigned int64_t)B8(db4 <<32) \
-+ ((unsigned int64_t)B8(dm5)<<24) \
-+ ((unsigned int64_t)B8(db6)<<16) \
-+ ((unsigned int64_t)B8(db7)<<8 ) \
-+ B8(dlsb))
-
-
-/* Sample usage:
-B8(01010101) = 85
-B16(10101010,01010101) = 43605
-B32(10000000,11111111,10101010,01010101) = 2164238933
-*/
Deleted: trunk/SASxport/src/IEEEtoIBM.c
===================================================================
--- trunk/SASxport/src/IEEEtoIBM.c 2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/IEEEtoIBM.c 2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,109 +0,0 @@
-//#include "writeSAS.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import <assert.h>
-#import <sys/types.h>
-
-typedef struct { /* IBM floating point format */
- unsigned sign : 1; /* Sign bit */
- unsigned exponent: 7; /* Exponent */
- //unsigned fraction: 56; /* Fraction */
- unsigned fraction1: 24; /* Top half of fraction */
- unsigned fraction2: 32; /* Lower half of fraction */
-} IBM_fp_struct;
-
-
-typedef struct { /* IEEE floating point format */
- unsigned sign : 1; /* Sign bit */
- unsigned exponent: 11; /* Exponent */
- // unsigned fraction: 52; /* Fraction */
- unsigned fraction1: 20; /* Top half of fraction */
- unsigned fraction2: 32; /* Lower half of fraction */
-} IEEE_fp_struct;
-
-
-int IEEEtoIBM(double *ieee, double *ibm )
-{
- IEEE_fp_struct *ieee_fp = (IEEE_fp_struct*) ieee;
- IBM_fp_struct *ibm_fp = (IBM_fp_struct* ) ibm;
- int64_t sign;
- int64_t exponent;
- int64_t fraction;
- short low_exp_bits;
-
- /*** Extract Pieces ***/
- // Sign = Ieee & Ieee_Sign;
- // Exponent = *Ieee & Ieee_Exp;
- // Fraction = *Ieee & Ieee_Frac;
-
- printf("1\n");
-
- /*** copy IEEE sign to IBM sign ***/
- ibm_fp->sign = ieee_fp->sign;
-
- printf("2\n");
-
- /*** convert IEEE exponent to IBM exponent ***/
- exponent = ieee_fp->exponent;
-
- printf("3\n");
-
- /* store lowest 2 bits from exponent */
- low_exp_bits = exponent % 16;
-
-
- printf("4\n");
-
- /* divide exponent by 4 to get from IEEE pow(2) exponent to IBM pow(16) exponent */
- exponent = exponent >> 2;
-
- printf("5\n");
-
-
- /* put it into the return value */
- ibm_fp->exponent = exponent;
-
- printf("6\n");
-
-
- /*** convert IEEE fraction to IBM fraction */
- fraction = ((int64_t) ieee_fp->fraction1 ) << 32 | ((int64_t) ieee_fp->fraction2);
-
- printf("7\n");
-
-
- /* shift left by low order bits lost from exponent */
- fraction = fraction << (low_exp_bits && 0x03);
-
-
- printf("8\n");
-
- /* add leading 1 bit */
- fraction >> 1;
- fraction = fraction | ( ((int64_t) 1) <<55 );
-
- printf("9\n");
-
-
- ibm_fp->fraction1 = (int32_t) (fraction >> 32) | 0x0FFFFF;
- ibm_fp->fraction2 = (int32_t) fraction;
-
-
- printf("10\n");
-
-
- char *buf= (char*) ibm;
- char tmp;
- int i;
- for(i=0; i<8; i++)
- {
- tmp = buf[7-i];
- buf[7-i] = buf[i];
- buf[i] = tmp;
- }
-
- return 0;
-}
-
Deleted: trunk/SASxport/src/MASKS.h
===================================================================
--- trunk/SASxport/src/MASKS.h 2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/MASKS.h 2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,23 +0,0 @@
-/* Masks for IBM fields */
-#define IBM_SIGN B64(10000000, 0000000, 0000000, 00000000, \
- 00000000, 0000000, 0000000, 00000000)
-
-#define IBM_EXP B64(01111111, 0000000, 0000000, 00000000, \
- 00000000, 0000000, 0000000, 00000000)
-
-#define IBM_FRAC B64(00000000, 1111111, 1111111, 11111111, \
- 11111111, 1111111, 1111111, 11111111)
-
-#define IBM_FRAC_MSB B64(00000000, 1000000, 0000000, 00000000, \
- 00000000, 0000000, 0000000, 00000000)
-
-/* Masks for IEEE fields */
-#define IEEE_SIGN B64(10000000, 0000000, 0000000, 00000000, \
- 00000000, 0000000, 0000000, 00000000)
-
-#define IEEE_EXP B64(01111111, 1111000, 0000000, 00000000, \
- 00000000, 0000000, 0000000, 00000000)
-
-#define IEEE_FRAC B64(00000000, 0000111, 1111111, 11111111, \
- 11111111, 1111111, 1111111, 11111111)
-
Deleted: trunk/SASxport/src/main.c
===================================================================
--- trunk/SASxport/src/main.c 2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/main.c 2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,55 +0,0 @@
-#include <math.h>
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import <assert.h>
-#import <sys/types.h>
-
-
-extern int cnxptiee(char *from, int fromtype, char *to, int totype);
-int IEEEtoIBM(double *ieee, double *ibm );
-
-int main(int argc, char *argv)
-{
- double ieee;
- double ibm_sas, ieee_sas;
- double ibm_our, ieee_our;
- char *ibm_sas_c = (char*) &ibm_sas;
- char *ibm_our_c = (char*) &ibm_our;
-
-
- for(int i=0; i<10; i++)
- {
- ieee = pow(2.0, ((double) i)) + 1.0 + 1.0 / ( ((double) i) + 1.0);
-
- /* from ieee to ibm, SAS code */
- cnxptiee( (char*) &ieee, 0, (char*) &ibm_sas, 1 );
-
- /* and back again, SAS code */
- cnxptiee( (char*) &ibm_sas, 1, (char*) &ieee_sas, 0 );
-
-
- /* from ieee to ibm, our code */
- IEEEtoIBM( &ieee, &ibm_our );
-
- /* and back again, SAS code */
- cnxptiee( (char*) &ibm_our, 1, (char*) &ieee_our, 0 );
-
-
- printf("i=%5d, ieee=%10f, ieee_sas=%10f ieee_our=%10f \n", i,
- ieee, ieee_sas, ieee_our);
-
- for(int index=0; index<8; index++)
- {
- printf(" ");
- printf("%2x ", ibm_sas_c[index]);
- printf("%2x ", ibm_our_c[index]);
- printf("\n");
- }
- printf("\n");
-
- }
-
- return 0;
-}
-
Deleted: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c 2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/reverse.c 2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,83 +0,0 @@
-#include "writeSAS.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import <assert.h>
-#import <sys/types.h>
-
-/* reverse: convert current byte order to little endian */
-void reverse( u_char *intp, size_t size)
-{
- static u_char endianTest[2] = {0x01,0x00};
- size_t i;
- u_char tmp;
-
-#if !defined(BIG_ENDIAN) && !defined(LITTLE_ENDIAN)
- /* Test if we are on a big endian or little endian platform */
- if( (short) *endianTest == 1 )
- {
- /* Little Endian */
- /* Do nothing */
- return;
- }
-#endif
-
- /* Big Endian */
- /* Swap bytes */
- for(i=0; i < size/2; i++)
- {
- tmp = (u_char) intp[i];
- intp[i] = intp[size-i-1];
- intp[size-i] = tmp;
- }
-
- return;
-}
-
-
-/* test code */
-void test_reverse()
-{
- u_char byte_pattern[1] = { 0x00 };
- u_char byte_value = 0x00;
-
- u_char short_pattern[2] = { 0x00, 0x01 }; /* NB: little endian byte pattern */
- short short_value = 0x0100; /* NB: hex is written big endian */
-
- u_char int_pattern[4] = { 0x0, 0x01, 0x02, 0x03 };
- int int_value = 0x03020100;
-
- u_char long_pattern[4] = { 0x0, 0x01, 0x02, 0x03 };
- long long_value = 0x03020100;
-
- /* Do the reverse, then test */
-
- /* byte */
- REVERSE( &byte_value, sizeof(u_char) );
- assert( (u_char) *byte_pattern == byte_value );
-
- /* short */
- REVERSE( &short_value, sizeof(short) );
- assert( *((short *) short_pattern) == short_value );
-
- /* int */
- REVERSE( &int_value, sizeof(int) );
- assert( *((int *) int_pattern) == int_value );
-
- /* long */
- REVERSE( &long_value, sizeof(long) );
- assert( *((long*) long_pattern) == long_value );
-
-}
-
-
-#ifdef DO_TEST
-int main(int argc, u_char *argv)
-{
- test_reverse();
-}
-
-
-
-#endif
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-08-21 18:12:42
|
Revision: 1155
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1155&view=rev
Author: warnes
Date: 2007-08-21 11:12:39 -0700 (Tue, 21 Aug 2007)
Log Message:
-----------
Commit previous updates
Modified Paths:
--------------
trunk/SASxport/src/init.c
trunk/SASxport/src/reverse.c
trunk/SASxport/src/test_fields.c
Added Paths:
-----------
trunk/SASxport/src/ibm2ieee.c
trunk/SASxport/src/ieee2ibm.c
Removed Paths:
-------------
trunk/SASxport/src/htond.c
Deleted: trunk/SASxport/src/htond.c
===================================================================
--- trunk/SASxport/src/htond.c 2007-08-21 15:36:28 UTC (rev 1154)
+++ trunk/SASxport/src/htond.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -1,148 +0,0 @@
-/* H T O N D . C
- * BRL-CAD
- *
- * Copyright (c) 2004-2007 United States Government as represented by
- * the U.S. Army Research Laboratory.
- *
- * Minor changes (c) 2007 Random Technologies LLC by Gregory R. Warnes
- * <gr...@ra...>
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * version 2.1 as published by the Free Software Foundation.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this file; see the file named COPYING for more
- * information.
- */
-
-#include "writeSAS.h"
-#include <stdio.h>
-
-/****************************/
-/** NB: htond code ommitted */
-/****************************/
-
-/****************************
- * NB: The ntohd code assumes that 'in' points to a vector BIG-ENDIAN IEEE
- * double precision value of length 'count'. This extracted routine
- * returns IBM/360 format double precision values in *out
- ***************************/
-
-
-void R_ntohd(double out[], double in[], int *count)
-{
- int i;
- int j;
- unsigned char tmp;
- unsigned char *cptr;
-
- /* Flip byte order from little endian to big endian */
- for(i=0; i<*count; i++)
- reverse( (unsigned char*) &(in[i]), sizeof(double) );
- ieee2ibm( (unsigned char *) out, (unsigned char *) in, *count );
-}
-
-/**
- * N T O H D
- *
- * @brief Network to Host Doubles
- */
-// Original function name: "ntohd"
-void ieee2ibm(register unsigned char *out, register const unsigned char *in, int count)
-{
- /*
- * IBM Format.
- * 7-bit exponent, base 16.
- * No hidden bits in mantissa (56 bits).
- */
- register int i;
- for( i=count-1; i >= 0; i-- ) {
- register unsigned long left, right;
- register int fix, exp, signbit;
-
- left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
- right = (in[4]<<24) | (in[5]<<16) | (in[6]<<8) | in[7];
- in += 8;
-
- exp = ((left >> 20) & 0x7FF);
- signbit = (left & 0x80000000) >> 24;
- if( exp == 0 || exp == 0x7FF ) {
-ibm_undef: *out++ = 0; /* IBM zero. No NAN */
- *out++ = 0;
- *out++ = 0;
- *out++ = 0;
- *out++ = 0;
- *out++ = 0;
- *out++ = 0;
- *out++ = 0;
- continue;
- }
-
- left = (left & 0x000FFFFF) | 0x00100000;/* replace "hidden" bit */
-
- exp += 129 - 1023 -1; /* fudge, to make /4 and %4 work */
- fix = exp % 4; /* 2^4 == 16^1; get fractional exp */
- exp /= 4; /* excess 32, base 16 */
- exp += (64-32+1); /* excess 64, base 16, plus fudge */
- if( (exp & ~0xFF) != 0 ) {
- //WARNING("ntohd: IBM exponent overflow");
- fprintf(stderr,"ntohd: IBM exponent overflow\n");
- goto ibm_undef;
- }
-
- if( fix ) {
- left = (left<<fix) | (right >> (32-fix));
- right <<= fix;
- }
-
- if( signbit ) {
- /* The IBM actually uses complimented mantissa
- * and exponent.
- */
- left ^= 0xFFFFFFFF;
- right ^= 0xFFFFFFFF;
- if( right & 0x80000000 ) {
- /* There may be a carry */
- right += 1;
- if( (right & 0x80000000) == 0 ) {
- /* There WAS a carry */
- left += 1;
- }
- } else {
- /* There will be no carry to worry about */
- right += 1;
- }
- left &= 0x00FFFFFF;
- exp = (~exp) & 0x7F;
- }
-
-
- /* Not actually required, but for comparison purposes,
- * normalize the number. Remove for production speed.
- */
- while( (left & 0x00F00000) == 0 && left != 0 ) {
- if( signbit && exp <= 0x41 ) break;
-
- left = (left << 4) | (right >> (32-4));
- right <<= 4;
- if(signbit) exp--;
- else exp++;
- }
-
- *out++ = signbit | exp;
- *out++ = left>>16;
- *out++ = left>>8;
- *out++ = left;
- *out++ = right>>24;
- *out++ = right>>16;
- *out++ = right>>8;
- *out++ = right;
- }
- return;
-}
Added: trunk/SASxport/src/ibm2ieee.c
===================================================================
--- trunk/SASxport/src/ibm2ieee.c (rev 0)
+++ trunk/SASxport/src/ibm2ieee.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -0,0 +1,171 @@
+/*
+ * File: SASxport/src/ibm2ieee.c
+ *
+ * Originally from BRL-CAD file /brlcad/src/libbu/htond.c
+ *
+ * Copyright (c) 2004-2007 United States Government as represented by
+ * the U.S. Army Research Laboratory.
+ *
+ * * Minor changes (c) 2007 Random Technologies LLC by Gregory R. Warnes
+ * <gr...@ra...>
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * version 2.1 as published by the Free Software Foundation.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this file; see the file named COPYING for more
+ * information.
+ */
+
+#include "writeSAS.h"
+#include <stdio.h>
+
+/****************************
+ * ibm2ieee
+ *
+ * Convert an array of IBM/360 format double precision values of at *in
+ * of length 'count' to BIG-ENDIAN IEEE double precision value at *out.
+ *
+ * This code was extracted from the "ntohd" function, original author
+ * Michael John Muuss
+ *
+ * Note that neither the input or output buffers need be word aligned,
+ * for greatest flexability in converting data, even though this
+ * imposes a speed penalty here.
+ *
+ ***************************/
+
+#define OUT_IEEE_ZERO { \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ *out++ = 0; \
+ continue; } \
+
+#define OUT_IEEE_NAN { /* Signaling NAN */ \
+ *out++ = 0xFF; \
+ *out++ = 0xF0; \
+ *out++ = 0x0B; \
+ *out++ = 0xAD; \
+ *out++ = 0x0B; \
+ *out++ = 0xAD; \
+ *out++ = 0x0B; \
+ *out++ = 0xAD; \
+ continue; } \
+
+
+void ibm2ieee(register unsigned char *out, register const unsigned char *in, int count)
+{
+ /*
+ * IBM Format.
+ * 7-bit exponent, base 16.
+ * No hidden bits in mantissa (56 bits).
+ */
+ register int i;
+ for( i=count-1; i >= 0; i-- ) {
+ register unsigned long left, right, signbit;
+ register int exp;
+
+ left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
+ right = (in[4]<<24) | (in[5]<<16) | (in[6]<<8) | in[7];
+ in += 8;
+
+ exp = (left>>24) & 0x7F; /* excess 64, base 16 */
+ if( left == 0 && right == 0 )
+ OUT_IEEE_ZERO;
+
+ signbit = left & 0x80000000;
+ left &= 0x00FFFFFF;
+ if( signbit ) {
+ /* The IBM uses 2's compliment on the mantissa,
+ * and IEEE does not.
+ */
+ left ^= 0xFFFFFFFF;
+ right ^= 0xFFFFFFFF;
+ if( right & 0x80000000 ) {
+ /* There may be a carry */
+ right += 1;
+ if( (right & 0x80000000) == 0 ) {
+ /* There WAS a carry */
+ left += 1;
+ }
+ } else {
+ /* There will be no carry to worry about */
+ right += 1;
+ }
+ left &= 0x00FFFFFF;
+ exp = (~exp) & 0x7F;
+ }
+ exp -= (64-32+1); /* excess 32, base 16, + fudge */
+ exp *= 4; /* excess 128, base 2 */
+ibm_normalized:
+ if( left & 0x00800000 ) {
+ /* fix = 0; */
+ exp += 1023-129+1+ 3-0;/* fudge, slide hidden bit */
+ } else if( left & 0x00400000 ) {
+ /* fix = 1; */
+ exp += 1023-129+1+ 3-1;
+ left = (left<<1) |
+ ( (right>>(32-1)) & (0x7FFFFFFF>>(31-1)) );
+ right <<= 1;
+ } else if( left & 0x00200000 ) {
+ /* fix = 2; */
+ exp += 1023-129+1+ 3-2;
+ left = (left<<2) |
+ ( (right>>(32-2)) & (0x7FFFFFFF>>(31-2)) );
+ right <<= 2;
+ } else if( left & 0x00100000 ){
+ /* fix = 3; */
+ exp += 1023-129+1+ 3-3;
+ left = (left<<3) |
+ ( (right>>(32-3)) & (0x7FFFFFFF>>(31-3)) );
+ right <<= 3;
+ } else {
+ /* Encountered 4 consecutive 0 bits of mantissa,
+ * attempt to normalize, and loop.
+ * This case was not expected, but does happen,
+ * at least on the Gould.
+ */
+ exp -= 4;
+ left = (left<<4) | (right>>(32-4));
+ right <<= 4;
+ goto ibm_normalized;
+ }
+
+ /* After suitable testing, this check can be deleted */
+ if( (left & 0x00800000) == 0 ) {
+ fprintf(stderr,"ibm->ieee missing 1, left=x%x\n", left);
+ left = (left<<1) | (right>>31);
+ right <<= 1;
+ goto ibm_normalized;
+ }
+
+ /* Having nearly VAX format, shift to IEEE, rounding. */
+# ifdef ROUNDING
+ right = (left<<(32-3)) | ((right+4)>>3);
+# else
+ right = (left<<(32-3)) | (right>>3);
+# endif
+ left = ((left & 0x007FFFFF)>>3) | signbit | (exp<<20);
+
+ *out++ = left>>24;
+ *out++ = left>>16;
+ *out++ = left>>8;
+ *out++ = left;
+ *out++ = right>>24;
+ *out++ = right>>16;
+ *out++ = right>>8;
+ *out++ = right;
+ }
+ return;
+}
Added: trunk/SASxport/src/ieee2ibm.c
===================================================================
--- trunk/SASxport/src/ieee2ibm.c (rev 0)
+++ trunk/SASxport/src/ieee2ibm.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -0,0 +1,135 @@
+/*
+ * File: SASxport/src/ibm2ieee.c
+ *
+ * Originally from BRL-CAD, file /brlcad/src/libbu/htond.c
+ *
+ * Copyright (c) 2004-2007 United States Government as represented by
+ * the U.S. Army Research Laboratory.
+ *
+ * Minor changes (c) 2007 Random Technologies LLC by Gregory R. Warnes
+ * <gr...@ra...>
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * version 2.1 as published by the Free Software Foundation.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this file; see the file named COPYING for more
+ * information.
+ */
+
+#include "writeSAS.h"
+#include <stdio.h>
+
+/****************************
+ * ieee2ibm
+ *
+ * Convert an array of BIG-ENDIAN IEEE double precision value at *in
+ * of length 'count'to IBM/360 format double precision values at *out
+ *
+ * This code was extracted from the "ntohd" function, original author
+ * Michael John Muuss
+ *
+ * Note that neither the input or output buffers need be word aligned,
+ * for greatest flexability in converting data, even though this
+ * imposes a speed penalty here.
+ *
+ ***************************/
+
+void ieee2ibm(register unsigned char *out, register const unsigned char *in, int count)
+{
+ /*
+ * IBM Format.
+ * 7-bit exponent, base 16.
+ * No hidden bits in mantissa (56 bits).
+ */
+ register int i;
+ for( i=count-1; i >= 0; i-- ) {
+ register unsigned long left, right;
+ register int fix, exp, signbit;
+
+ left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
+ right = (in[4]<<24) | (in[5]<<16) | (in[6]<<8) | in[7];
+ in += 8;
+
+ exp = ((left >> 20) & 0x7FF);
+ signbit = (left & 0x80000000) >> 24;
+ if( exp == 0 || exp == 0x7FF ) {
+ibm_undef: *out++ = 0; /* IBM zero. No NAN */
+ *out++ = 0;
+ *out++ = 0;
+ *out++ = 0;
+ *out++ = 0;
+ *out++ = 0;
+ *out++ = 0;
+ *out++ = 0;
+ continue;
+ }
+
+ left = (left & 0x000FFFFF) | 0x00100000;/* replace "hidden" bit */
+
+ exp += 129 - 1023 -1; /* fudge, to make /4 and %4 work */
+ fix = exp % 4; /* 2^4 == 16^1; get fractional exp */
+ exp /= 4; /* excess 32, base 16 */
+ exp += (64-32+1); /* excess 64, base 16, plus fudge */
+ if( (exp & ~0xFF) != 0 ) {
+ //WARNING("ntohd: IBM exponent overflow");
+ fprintf(stderr,"ntohd: IBM exponent overflow\n");
+ goto ibm_undef;
+ }
+
+ if( fix ) {
+ left = (left<<fix) | (right >> (32-fix));
+ right <<= fix;
+ }
+
+ if( signbit ) {
+ /* The IBM actually uses complimented mantissa
+ * and exponent.
+ */
+ left ^= 0xFFFFFFFF;
+ right ^= 0xFFFFFFFF;
+ if( right & 0x80000000 ) {
+ /* There may be a carry */
+ right += 1;
+ if( (right & 0x80000000) == 0 ) {
+ /* There WAS a carry */
+ left += 1;
+ }
+ } else {
+ /* There will be no carry to worry about */
+ right += 1;
+ }
+ left &= 0x00FFFFFF;
+ exp = (~exp) & 0x7F;
+ }
+
+
+ /* Not actually required, but for comparison purposes,
+ * normalize the number. Remove for production speed.
+ */
+ while( (left & 0x00F00000) == 0 && left != 0 ) {
+ if( signbit && exp <= 0x41 ) break;
+
+ left = (left << 4) | (right >> (32-4));
+ right <<= 4;
+ if(signbit) exp--;
+ else exp++;
+ }
+
+ *out++ = signbit | exp;
+ *out++ = left>>16;
+ *out++ = left>>8;
+ *out++ = left;
+ *out++ = right>>24;
+ *out++ = right>>16;
+ *out++ = right>>8;
+ *out++ = right;
+ }
+ return;
+}
Modified: trunk/SASxport/src/init.c
===================================================================
--- trunk/SASxport/src/init.c 2007-08-21 15:36:28 UTC (rev 1154)
+++ trunk/SASxport/src/init.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -1,6 +1,6 @@
/*******
*
- * init.c: Routines to register writeSAS.c routines with R
+ * init.c: Routines to register SASxport C routines with R
*
* Author: Gregory R. Warnes <gr...@ra...>
*
@@ -57,8 +57,6 @@
#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
static const R_CallMethodDef CallEntries[] = {
-// CALLDEF(xport_info, 1),
-// CALLDEF(xport_read, 2),
CALLDEF(getRawBuffer, 0),
{NULL, NULL, 0}
};
Modified: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c 2007-08-21 15:36:28 UTC (rev 1154)
+++ trunk/SASxport/src/reverse.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -3,8 +3,8 @@
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
-#import <assert.h>
-#import <sys/types.h>
+#include <assert.h>
+#include <sys/types.h>
/* reverse: convert current byte order to big endian */
void reverse( unsigned char *intp, size_t size)
Modified: trunk/SASxport/src/test_fields.c
===================================================================
--- trunk/SASxport/src/test_fields.c 2007-08-21 15:36:28 UTC (rev 1154)
+++ trunk/SASxport/src/test_fields.c 2007-08-21 18:12:39 UTC (rev 1155)
@@ -181,7 +181,6 @@
}
-
void doTest()
{
/* small buffer */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-11-01 06:15:17
|
Revision: 1204
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1204&view=rev
Author: warnes
Date: 2007-10-31 23:15:13 -0700 (Wed, 31 Oct 2007)
Log Message:
-----------
Copy code from foreign for lookup.xport() and read.xport(), extend lookup.xport() to show information about SAS format and iformat
Modified Paths:
--------------
trunk/SASxport/src/ieee2ibm.c
trunk/SASxport/src/init.c
Added Paths:
-----------
trunk/SASxport/src/swap_bytes.h
Modified: trunk/SASxport/src/ieee2ibm.c
===================================================================
--- trunk/SASxport/src/ieee2ibm.c 2007-11-01 06:14:22 UTC (rev 1203)
+++ trunk/SASxport/src/ieee2ibm.c 2007-11-01 06:15:13 UTC (rev 1204)
@@ -43,6 +43,9 @@
void ieee2ibm(register unsigned char *out, register const unsigned char *in, int count)
{
+ static char numeric_NA[8] = {0x2e,0x00,0x00,0x00,0x00,0x00,0x00,0x00};
+
+
/*
* IBM Format.
* 7-bit exponent, base 16.
@@ -61,7 +64,7 @@
signbit = (left & 0x80000000) >> 24;
if( exp == 0 || exp == 0x7FF ) {
-ibm_undef: *out++ = 0; /* IBM zero. No NAN */
+ *out++ = 0; /* IBM zero. No NAN */
*out++ = 0;
*out++ = 0;
*out++ = 0;
@@ -79,9 +82,10 @@
exp /= 4; /* excess 32, base 16 */
exp += (64-32+1); /* excess 64, base 16, plus fudge */
if( (exp & ~0xFF) != 0 ) {
- //WARNING("ntohd: IBM exponent overflow");
- fprintf(stderr,"ntohd: IBM exponent overflow\n");
- goto ibm_undef;
+ warning("IBM exponent overflow, generating NA\n");
+ memcpy(out, numeric_NA, 8);
+ out+= 8;
+ continue;
}
if( fix ) {
Modified: trunk/SASxport/src/init.c
===================================================================
--- trunk/SASxport/src/init.c 2007-11-01 06:14:22 UTC (rev 1203)
+++ trunk/SASxport/src/init.c 2007-11-01 06:15:13 UTC (rev 1204)
@@ -55,9 +55,14 @@
{ NULL, NULL, 0}
};
+SEXP xport_info(SEXP xportFile);
+SEXP xport_read(SEXP xportFile, SEXP xportInfo);
+
#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
static const R_CallMethodDef CallEntries[] = {
- CALLDEF(getRawBuffer, 0),
+ CALLDEF(getRawBuffer, 0),
+ CALLDEF(xport_info, 1),
+ CALLDEF(xport_read, 2),
{NULL, NULL, 0}
};
Added: trunk/SASxport/src/swap_bytes.h
===================================================================
--- trunk/SASxport/src/swap_bytes.h (rev 0)
+++ trunk/SASxport/src/swap_bytes.h 2007-11-01 06:15:13 UTC (rev 1204)
@@ -0,0 +1,172 @@
+/* src/swap_bytes.h. Generated by configure. */
+/*
+ *
+ * Reverse bytes in 2, 4 and 8 byte objects
+ *
+ * Copyright 2000-2000 Saikat DebRoy <sa...@st...>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be
+ * useful, but WITHOUT ANY WARRANTY; without even the implied
+ * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+ * PURPOSE. See the GNU General Public License for more
+ * details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#ifndef SWAP_BYTES_H
+#define SWAP_BYTES_H
+
+/* #undef HAVE_GLIBC_BSWAP */
+
+#ifdef HAVE_GLIBC_BSWAP /* use gnu bswap macros */
+
+#include <byteswap.h>
+
+#define swap_bytes_16(from, to) do { (to) = bswap_16(from); } while (0)
+
+#define swap_bytes_32(from, to) do { (to) = bswap_32(from); } while (0)
+
+#if defined __GNUC__ && __GNUC__ >= 2
+
+#define swap_bytes_double(from, to) \
+do { \
+ union { \
+ unsigned long long int u64; \
+ double d; \
+ } __from, __to; \
+ __from.d = (from); \
+ __to.u64 = bswap_64(__from.u64); \
+ (to) = __to.d; \
+} while (0)
+
+#else
+
+#define swap_bytes_double(from, to) \
+do { \
+ union { \
+ unsigned int u32[2]; \
+ double d; \
+ } __from, __to; \
+ __from.d = (from); \
+ swap_bytes_32(__from.u32[1], __to.u32[0]); \
+ swap_bytes_32(__from.u32[0], __to.u32[1]); \
+ (to) = __to.d; \
+} while (0)
+
+#endif
+
+#else /* use reasonable portable definitions */
+
+#define swap_bytes_16(from, to) \
+do { \
+ unsigned short __from16 = (from); \
+ (to) = ((((__from16) >> 8) & 0xff) | (((__from16) & 0xff) << 8)); \
+} while (0)
+
+#define swap_bytes_32(from, to) \
+do { \
+ unsigned int __from32 = (from); \
+ (to) = (((__from32 & 0xff000000) >> 24) | \
+ ((__from32 & 0x00ff0000) >> 8) | \
+ ((__from32 & 0x0000ff00) << 8) | \
+ ((__from32 & 0x000000ff) << 24)); \
+} while (0)
+
+#define swap_bytes_double(from, to) \
+do { \
+ union { \
+ unsigned int u32[2]; \
+ double d; \
+ } __from, __to; \
+ __from.d = (from); \
+ swap_bytes_32(__from.u32[1], __to.u32[0]); \
+ swap_bytes_32(__from.u32[0], __to.u32[1]); \
+ (to) = __to.d; \
+} while (0)
+#endif /* HAVE_GLIBC_BSWAP */
+
+#define swap_bytes_ushort(from, to) swap_bytes_16(from, to)
+
+#define reverse_ushort(x) swap_bytes_16(x, x)
+
+#define swap_bytes_short(from, to) \
+do { \
+ union { \
+ unsigned short u16; \
+ short s16; \
+ } __from, __to; \
+ __from.s16 = (from); \
+ swap_bytes_16(__from.u16, __to.u16); \
+ (to) = __to.s16; \
+} while (0)
+
+#define reverse_short(x) \
+do { \
+ union { \
+ unsigned short u16; \
+ short s16; \
+ } __from, __to; \
+ __from.s16 = (x); \
+ swap_bytes_16(__from.u16, __to.u16); \
+ (x) = __to.s16; \
+} while(0)
+
+#define swap_bytes_uint(from, to) swap_bytes_32(from, to)
+
+#define reverse_uint(x) swap_bytes_32(x, x)
+
+#define swap_bytes_int(from, to) \
+do { \
+ union { \
+ unsigned int u32; \
+ int s32; \
+ } __from, __to; \
+ __from.s32 = (from); \
+ swap_bytes_32(__from.u32, __to.u32); \
+ (to) = __to.s32; \
+} while(0)
+
+#define reverse_int(x) \
+do { \
+ union { \
+ unsigned int u32; \
+ int s32; \
+ } __from, __to; \
+ __from.s32 = (x); \
+ swap_bytes_32(__from.u32, __to.u32); \
+ (x) = __to.s32; \
+} while(0)
+
+#define swap_bytes_float(from, to) \
+do { \
+ union { \
+ unsigned int u32; \
+ float f; \
+ } __from, __to; \
+ __from.f = (from); \
+ swap_bytes_32(__from.u32, __to.u32); \
+ (to) = __to.f; \
+} while(0)
+
+#define reverse_float(x) \
+do { \
+ union { \
+ unsigned int u32; \
+ float f; \
+ } __from, __to; \
+ __from.f = (x); \
+ swap_bytes_32(__from.u32, __to.u32); \
+ (x) = __to.f; \
+} while(0)
+
+#define reverse_double(x) swap_bytes_double(x, x)
+
+#endif /* SWAP_BYTES_H */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-11-07 18:14:59
|
Revision: 1223
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1223&view=rev
Author: warnes
Date: 2007-11-07 10:14:58 -0800 (Wed, 07 Nov 2007)
Log Message:
-----------
Apply patches to fix problems on 64 bit platforms, as sumitted by Brian Ripley, and to replace assert() calls with calls a macro that maps to error() unless standalone testing is being done, in which case assert() is used.
Modified Paths:
--------------
trunk/SASxport/src/ibm2ieee.c
trunk/SASxport/src/reverse.c
trunk/SASxport/src/writeSAS.c
trunk/SASxport/src/writeSAS.h
Modified: trunk/SASxport/src/ibm2ieee.c
===================================================================
--- trunk/SASxport/src/ibm2ieee.c 2007-11-06 16:24:50 UTC (rev 1222)
+++ trunk/SASxport/src/ibm2ieee.c 2007-11-07 18:14:58 UTC (rev 1223)
@@ -73,7 +73,7 @@
*/
register int i;
for( i=count-1; i >= 0; i-- ) {
- register unsigned long left, right, signbit;
+ register unsigned left, right, signbit;
register int exp;
left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
Modified: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c 2007-11-06 16:24:50 UTC (rev 1222)
+++ trunk/SASxport/src/reverse.c 2007-11-07 18:14:58 UTC (rev 1223)
@@ -1,4 +1,4 @@
-//#include "writeSAS.h"
+#include "writeSAS.h"
#include <stdio.h>
#include <string.h>
@@ -34,7 +34,6 @@
return;
}
-
/* test code */
void test_reverse()
{
@@ -54,28 +53,25 @@
/* byte */
reverse( &byte_value, sizeof(unsigned char) );
- assert( (unsigned char) *byte_pattern == byte_value );
+ ASSERT( (unsigned char) *byte_pattern == byte_value );
/* short */
reverse( (unsigned char*) &short_value, sizeof(short) );
- assert( *((short *) short_pattern) == short_value );
+ ASSERT( *((short *) short_pattern) == short_value );
/* int */
reverse( (unsigned char*) &int_value, sizeof(int) );
- assert( *((int *) int_pattern) == int_value );
+ ASSERT( *((int *) int_pattern) == int_value );
/* long */
reverse( (unsigned char*) &long_value, sizeof(long) );
- assert( *((long*) long_pattern) == long_value );
+ ASSERT( *((long*) long_pattern) == long_value );
}
-
#ifdef DO_TEST
int main(int argc, char *argv)
{
test_reverse();
}
-
-
#endif
Modified: trunk/SASxport/src/writeSAS.c
===================================================================
--- trunk/SASxport/src/writeSAS.c 2007-11-06 16:24:50 UTC (rev 1222)
+++ trunk/SASxport/src/writeSAS.c 2007-11-07 18:14:58 UTC (rev 1223)
@@ -250,14 +250,14 @@
blankCopy(namestr_record.niform, 8, niform[0]); /* NAME OF INPUT FORMAT */
namestr_record.nifl = (short) *nifl; /* INFORMAT LENGTH ATTRIBUTE */
namestr_record.nifd = (short) *nifd; /* INFORMAT NUMBER OF DECIMALS */
- namestr_record.npos = (long) *npos; /* POSITION OF VALUE IN OBSERVATION */
+ namestr_record.npos = (int) *npos; /* POSITION OF VALUE IN OBSERVATION */
zeroFill(namestr_record.rest, 52); /* remaining fields are irrelevant */
/* Flip byte order if necessary */
#define SHORTREV(a) REVERSE( &a, sizeof(short) )
-#define LONGREV(a) REVERSE( &a, sizeof(long) )
+#define INTREV(a) REVERSE( &a, sizeof(int) )
SHORTREV( namestr_record.ntype );
SHORTREV( namestr_record.nhfun );
@@ -269,7 +269,7 @@
SHORTREV( namestr_record.nifl );
SHORTREV( namestr_record.nifd );
- LONGREV ( namestr_record.npos );
+ INTREV ( namestr_record.npos );
/* copy filled struct to return area */
memcpy( raw_buffer, &namestr_record, sizeof(namestr_record) );
Modified: trunk/SASxport/src/writeSAS.h
===================================================================
--- trunk/SASxport/src/writeSAS.h 2007-11-06 16:24:50 UTC (rev 1222)
+++ trunk/SASxport/src/writeSAS.h 2007-11-07 18:14:58 UTC (rev 1223)
@@ -56,6 +56,11 @@
*****/
#define MIN(x,y) (x>y?y:x)
+#ifdef DO_TEST
+#define ASSERT(x) assert(x)
+#else
+#define ASSERT(x) if(!(x)) error("Assertion failed: x")
+#endif
/*****
@@ -128,7 +133,7 @@
short nifl; /* INFORMAT LENGTH ATTRIBUTE */
short nifd; /* INFORMAT NUMBER OF DECIMALS */
- long npos; /* POSITION OF VALUE IN OBSERVATION */
+ int npos; /* POSITION OF VALUE IN OBSERVATION */
char rest[52]; /* remaining fields are irrelevant */
};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <wa...@us...> - 2007-11-09 19:59:51
|
Revision: 1226
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1226&view=rev
Author: warnes
Date: 2007-11-09 11:59:48 -0800 (Fri, 09 Nov 2007)
Log Message:
-----------
Apply patches to fix problems on 64 bit platforms, as sumitted by Brian Ripley.
Modified Paths:
--------------
trunk/SASxport/src/ibm2ieee.c
trunk/SASxport/src/ieee2ibm.c
Modified: trunk/SASxport/src/ibm2ieee.c
===================================================================
--- trunk/SASxport/src/ibm2ieee.c 2007-11-07 19:01:02 UTC (rev 1225)
+++ trunk/SASxport/src/ibm2ieee.c 2007-11-09 19:59:48 UTC (rev 1226)
@@ -73,7 +73,7 @@
*/
register int i;
for( i=count-1; i >= 0; i-- ) {
- register unsigned left, right, signbit;
+ register unsigned int left, right, signbit;
register int exp;
left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
Modified: trunk/SASxport/src/ieee2ibm.c
===================================================================
--- trunk/SASxport/src/ieee2ibm.c 2007-11-07 19:01:02 UTC (rev 1225)
+++ trunk/SASxport/src/ieee2ibm.c 2007-11-09 19:59:48 UTC (rev 1226)
@@ -53,7 +53,7 @@
*/
register int i;
for( i=count-1; i >= 0; i-- ) {
- register unsigned long left, right;
+ register unsigned int left, right;
register int fix, exp, signbit;
left = (in[0]<<24) | (in[1]<<16) | (in[2]<<8) | in[3];
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X