/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.41 1989/12/29 20:41:06 pas Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.42 1990/01/15 18:09:25 pas Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
PRIMITIVE_RETURN (double_to_flonum (old_value));
}
\f
+/*____________________ file readers ___________
+ ascii and 2bint formats
+ ______________________________________________*/
+
+/* Reading data from files
+ To read REAL numbers, use "lf" for double, "%f" for float
+ */
#if (REAL_IS_DEFINED_DOUBLE == 1)
#define REALREAD "%lf"
#define REALREAD2 "%lf %lf"
#endif
static void
-C_Array_Read_Ascii_File (a, N, fp)
+C_Array_Read_Ascii_File (a, N, fp) /* 16 ascii decimal digits */
+ REAL * a;
+ long N;
+ FILE * fp;
+{
+ fast long i;
+ for (i = 0; (i < N); i += 1)
+ {
+ if ((fscanf (fp, REALREAD, (&(a[i])))) != 1)
+ { printf("Not enough values read ---\n last value a[%d] = % .16e \n", (i-1), a[i-1]);
+ error_external_return (); }
+ }
+ return;
+}
+
+/* 2BINT FORMAT = integer stored in 2 consecutive bytes.
+ On many machines, "putw" and "getw" use 4 byte integers (C int)
+ so use "putc" "getc" as shown below.
+ */
+
+static void
+C_Array_Read_2bint_File (a, N, fp)
REAL * a;
long N;
FILE * fp;
{
fast long i;
+ fast int msd;
for (i = 0; (i < N); i += 1)
{
- if ((fscanf (fp, REALREAD, (& (a [i])))) != 1)
+ if (feof (fp))
error_external_return ();
+ msd = (getc (fp));
+ (a [i]) = ((REAL) ((msd << 8) | (getc (fp))));
}
return;
}
-DEFINE_PRIMITIVE ("ARRAY-READ-ASCII-FILE", Prim_array_read_ascii_file, 2, 2, 0)
+DEFINE_PRIMITIVE ("ARRAY-READ-FROM-FILE", Prim_array_read_from_file, 3,3, 0)
{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, STRING_P);
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, STRING_P); /* 1 = filename */
+ /* 2 = length of data */
+ CHECK_ARG (3, FIXNUM_P); /* 3 = format of data 0=ascii 1=2bint */
{
fast long length = (arg_nonnegative_integer (2));
fast SCHEME_OBJECT result = (allocate_array (length));
- fast FILE * fp = (fopen ((ARG_REF (1)), "r"));
- if (fp == ((FILE *) 0))
+ int format;
+ fast FILE * fp;
+ if ( (fp = fopen((STRING_ARG (1)), "r")) == NULL)
error_bad_range_arg (1);
- C_Array_Read_Ascii_File ((ARRAY_CONTENTS (result)), length, fp);
+
+ format = arg_nonnegative_integer(3);
+ if (format==0)
+ C_Array_Read_Ascii_File ((ARRAY_CONTENTS (result)), length, fp);
+ else if (format==1)
+ C_Array_Read_2bint_File ((ARRAY_CONTENTS (result)), length, fp);
+ else
+ error_bad_range_arg(3); /* illegal format code */
+
if ((fclose (fp)) != 0)
error_external_return ();
PRIMITIVE_RETURN (result);
}
static void
-C_Array_Write_Ascii_File (a, N, fp)
+C_Array_Write_Ascii_File (a, N, fp) /* 16 ascii decimal digits */
REAL * a;
long N;
FILE * fp;
CHECK_ARG (2, STRING_P);
{
fast SCHEME_OBJECT array = (ARG_REF (1));
- fast FILE * fp = (fopen ((ARG_REF (2)), "w"));
+ fast FILE * fp = (fopen((STRING_ARG (2)), "w"));
if (fp == ((FILE *) 0))
error_bad_range_arg (2);
C_Array_Write_Ascii_File
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
-static void
-C_Array_Read_2bint_File (a, N, fp)
- REAL * a;
- long N;
- FILE * fp;
-{
- fast long i;
- fast int msd;
- for (i = 0; (i < N); i += 1)
- {
- if (feof (fp))
- error_external_return ();
- msd = (getc (fp));
- (a [i]) = ((REAL) ((msd << 8) | (getc (fp))));
- }
- return;
-}
-DEFINE_PRIMITIVE ("ARRAY-READ-2BINT-FILE", Prim_array_read_2bint_file, 2, 2, 0)
-{
- FILE * fp;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- fp = (fopen ((ARG_REF (1)), "r"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (1);
- {
- fast long length = (arg_nonnegative_integer (2));
- fast SCHEME_OBJECT result = (allocate_array (length));
- C_Array_Read_2bint_File ((ARRAY_CONTENTS (result)), length, fp);
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (result);
- }
-}
+
+
\f
DEFINE_PRIMITIVE ("SUBARRAY-COPY!", Prim_subarray_copy, 5, 5, 0)
{
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.30 1990/01/02 18:35:32 pas Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.31 1990/01/15 18:09:34 pas Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
error_external_return ();
return;
}
-\f
-DEFINE_PRIMITIVE ("READ-IMAGE-FROM-ASCII-FILE", Prim_read_image_from_ascii_file, 1, 1, 0)
+
+
+DEFINE_PRIMITIVE ("IMAGE-READ-ASCII", Prim_read_image_ascii, 1, 1, 0)
{
fast FILE * fp;
- long nrows;
- long ncols;
+ long nrows, ncols;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- fp = (fopen ((ARG_REF (1)), "r"));
- if (fp == ((FILE *) 0))
+ if ( (fp = fopen((STRING_ARG (1)), "r")) == NULL)
error_bad_range_arg (1);
fscanf (fp, "%d %d \n", (&nrows), (&ncols));
if ((ferror (fp)) || ((ncols > 512) || (nrows > 512)))
- error_external_return ();
+ { printf("read-image-ascii-file: problem with rows,cols \n");
+ error_bad_range_arg (1); }
{
fast long length = (nrows * ncols);
SCHEME_OBJECT array = (allocate_array (length));
fast REAL * scan = (ARRAY_CONTENTS (array));
while ((length--) > 0)
- {
- int one;
- int two;
- fscanf (fp, "%d%d", (&one), (&two));
+ { long number;
+ fscanf (fp, "%d", (&number));
if (ferror (fp))
error_external_return ();
- (*scan++) = ((REAL) one);
- (*scan++) = ((REAL) two);
+ (*scan++) = ((REAL) number);
}
- if ((fclose (fp)) != 0)
- error_external_return ();
+ if ((fclose (fp)) != 0) error_external_return ();
PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
}
}
-DEFINE_PRIMITIVE ("READ-IMAGE-FROM-CBIN-FILE", Prim_read_image_from_cbin_file, 1, 1, 0)
+DEFINE_PRIMITIVE ("IMAGE-READ-2BINT", Prim_read_image_2bint, 1, 1, 0)
{
- fast FILE * fp;
+ FILE *fp, *fopen();
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- fp = (fopen ((ARG_REF (1)), "r"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (1);
- {
- int nrows = (read_word (fp));
- int ncols = (read_word (fp));
- long length = (nrows * ncols);
- SCHEME_OBJECT array = (allocate_array (length));
- fast REAL * scan = (ARRAY_CONTENTS (array));
- while ((length--) > 0)
- (*scan++) = (read_word (fp));
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
- }
-}
-\f
-DEFINE_PRIMITIVE ("READ-IMAGE-FROM-2BINT-FILE", Prim_read_image_from_2bint_file, 1, 1, 0)
-{
- fast FILE * fp;
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- fp = (fopen ((ARG_REF (1)), "r"));
- if (fp == ((FILE *) 0))
+ if ( ( fp = (fopen((STRING_ARG (1)), "r")) ) == NULL)
error_bad_range_arg (1);
{
int nrows = (read_word (fp));
}
}
-DEFINE_PRIMITIVE ("WRITE-IMAGE-2BINT", Prim_write_image_2bint, 2, 2, 0)
-{
- int nrows;
- int ncols;
- SCHEME_OBJECT array;
- fast FILE * fp;
- PRIMITIVE_HEADER (2);
- arg_image (1, (&nrows), (&ncols), (&array));
- CHECK_ARG (2, STRING_P);
- fp = (fopen ((ARG_REF (2)), "2"));
- if (fp == ((FILE *) 0))
- error_bad_range_arg (2);
- {
- fast long length = (nrows * ncols);
- fast REAL * scan = (ARRAY_CONTENTS (array));
- write_word (fp, nrows);
- write_word (fp, ncols);
- while ((length--) > 0)
- write_2bint (fp, ((int) (*scan++)));
- }
- if ((fclose (fp)) != 0)
- error_external_return ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("READ-IMAGE-FROM-CTSCAN-FILE", Prim_read_image_from_ctscan_file, 1, 1, 0)
+DEFINE_PRIMITIVE ("IMAGE-READ-CTSCAN", Prim_read_image_ctscan, 1, 1, 0)
{
fast FILE * fp;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- fp = (fopen ((ARG_REF (1)), "r"));
+ fp = (fopen((STRING_ARG (1)), "r"));
if (fp == ((FILE *) 0))
error_bad_range_arg (1);
Primitive_GC_If_Needed (BYTES_TO_WORDS (512 * (sizeof (int))));
}
}
+
+DEFINE_PRIMITIVE ("IMAGE-READ-CBIN", Prim_read_image_cbin, 1, 1, 0)
+{
+ fast FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((STRING_ARG (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ {
+ int nrows = (read_word (fp));
+ int ncols = (read_word (fp));
+ long length = (nrows * ncols);
+ SCHEME_OBJECT array = (allocate_array (length));
+ fast REAL * scan = (ARRAY_CONTENTS (array));
+ while ((length--) > 0)
+ (*scan++) = (read_word (fp));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
+ }
+}
+
+\f
Image_Mirror_Upside_Down (Array,nrows,ncols,Temp_Row)
REAL * Array;
long nrows;
C_Array_Copy(Temp_Row, M_row, ncols);
}
}
-\f
+
/* The following does not work, to be fixed. */
DEFINE_PRIMITIVE ("IMAGE-DOUBLE-TO-FLOAT!", Prim_image_double_to_float, 1, 1, 0)
{
SET_VECTOR_LENGTH (array, ((Length * FLOAT_SIZE) + 1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
+
DEFINE_PRIMITIVE ("SUBIMAGE-COPY!", Prim_subimage_copy, 12, 12, 0)
{
long r1, c1, r2, c2, at1r, at1c, at2r, at2c, mr, mc;
yrow = yrow + c2;
}
}
-\f
+
/* image-operation-2
groups together procedures that use 2 image-arrays
(usually side-effecting the 2nd image, but not necessarily) */
projects / mit-scheme.git / commitdiff