Change the FILE-INFO primitive to return two additional items: the

attribute bits and the allocated file length.

diff --git a/v7/src/microcode/pros2fs.c b/v7/src/microcode/pros2fs.c
index 2785e3b217dab4a53e196b101cd29aa6904485f0..bd3bf3351df0e0cfb3a46468940c12a14440e398 100644 (file)
--- a/v7/src/microcode/pros2fs.c
+++ b/v7/src/microcode/pros2fs.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: pros2fs.c,v 1.12 1995/10/30 07:55:05 cph Exp $
+$Id: pros2fs.c,v 1.13 1995/10/31 08:04:27 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -88,7 +88,7 @@ DEFINE_PRIMITIVE ("FILE-LENGTH", Prim_file_length, 1, 1,
     PRIMITIVE_RETURN
       ((info == 0)
        ? SHARP_F
-       : (LONG_TO_UNSIGNED_FIXNUM (info -> cbFile)));
+       : (ulong_to_integer (info -> cbFile)));
   }
 }
 
@@ -157,6 +157,19 @@ DEFINE_PRIMITIVE ("FILE-ACCESS-TIME", Prim_file_acc_time, 1, 1, 0)
   }
 }
 
+static SCHEME_OBJECT
+time_to_integer (FDATE * date, FTIME * time)
+{
+  unsigned long accum;
+  accum = (date -> year);
+  accum = ((accum << 4) | (date -> month));
+  accum = ((accum << 5) | (date -> day));
+  accum = ((accum << 5) | (time -> hours));
+  accum = ((accum << 6) | (time -> minutes));
+  accum = ((accum << 5) | (time -> twosecs));
+  return (ulong_to_integer (accum));
+}
+
 DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
   "Change the access and modification times of FILE.\n\
 The second and third arguments are the respective times.\n\
@@ -194,6 +207,23 @@ The file must exist and you must be the owner (or superuser).")
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
 
+static void
+integer_to_time (SCHEME_OBJECT encoding, FDATE * date, FTIME * time)
+{
+  unsigned long accum = (integer_to_ulong (encoding));
+  (time -> twosecs) = (accum & 0x1f);
+  accum >>= 5;
+  (time -> minutes) = (accum & 0x3f);
+  accum >>= 6;
+  (time -> hours) = (accum & 0x1f);
+  accum >>= 5;
+  (date -> day) = (accum & 0x1f);
+  accum >>= 5;
+  (date -> month) = (accum & 0x0f);
+  accum >>= 4;
+  (date -> year) = accum;
+}
+\f
 DEFINE_PRIMITIVE ("FILE-TOUCH", Prim_file_touch, 1, 1,
   "Given a file name, change the times of the file to the current time.\n\
 If the file does not exist, create it.\n\
@@ -204,52 +234,7 @@ Otherwise the file did not exist and it was created.")
   PRIMITIVE_HEADER (1);
   PRIMITIVE_RETURN (file_touch ((CONST char *) (STRING_ARG (1))));
 }
-\f
-static SCHEME_OBJECT
-time_to_integer (FDATE * date, FTIME * time)
-{
-  unsigned long id;
-  unsigned long it;
-  id = (date -> year);
-  id = ((id << 4) | (date -> month));
-  id = ((id << 5) | (date -> day));
-  it = (time -> hours);
-  it = ((it << 6) | (time -> minutes));
-  it = ((it << 5) | (time -> twosecs));
-  return
-    (integer_add ((integer_multiply ((LONG_TO_UNSIGNED_FIXNUM (id)),
-                                    (LONG_TO_UNSIGNED_FIXNUM (0x10000)))),
-                 (LONG_TO_UNSIGNED_FIXNUM (it))));
-}
 
-static void
-integer_to_time (SCHEME_OBJECT encoding, FDATE * date, FTIME * time)
-{
-  unsigned long id;
-  unsigned long it;
-  {
-    SCHEME_OBJECT q;
-    SCHEME_OBJECT r;
-    (void) integer_divide
-      (encoding, (LONG_TO_UNSIGNED_FIXNUM (0x10000)), (&q), (&r));
-    it = (UNSIGNED_FIXNUM_TO_LONG (r));
-    /* If encoding is larger than 32 bits, ignore MS bits.  */
-    (void) integer_divide
-      (q, (LONG_TO_UNSIGNED_FIXNUM (0x10000)), (&q), (&r));
-    id = (UNSIGNED_FIXNUM_TO_LONG (r));
-  }
-  (date -> day) = (id & 0x1f);
-  id >>= 5;
-  (date -> month) = (id & 0x0f);
-  id >>= 4;
-  (date -> year) = id;
-  (time -> twosecs) = (it & 0x1f);
-  it >>= 5;
-  (time -> minutes) = (it & 0x3f);
-  it >>= 6;
-  (time -> hours) = it;
-}
-\f
 static SCHEME_OBJECT
 file_touch (const char * filename)
 {
@@ -335,14 +320,12 @@ Otherwise the result is #F.")
 {
   FILESTATUS3 * info;
   SCHEME_OBJECT result;
-  SCHEME_OBJECT modes;
   PRIMITIVE_HEADER (1);
 
   info = (OS2_read_file_status (STRING_ARG (1)));
   if (info == 0)
     PRIMITIVE_RETURN (SHARP_F);
-  result = (allocate_marked_vector (TC_VECTOR, 6, true));
-  modes = (allocate_string (5));
+  result = (allocate_marked_vector (TC_VECTOR, 8, true));
   VECTOR_SET (result, 0,
              ((((info -> attrFile) & FILE_DIRECTORY) != 0)
               ? SHARP_T
@@ -356,20 +339,23 @@ Otherwise the result is #F.")
   VECTOR_SET (result, 3,
              (time_to_integer ((& (info -> fdateCreation)),
                                (& (info -> ftimeCreation)))));
-  VECTOR_SET (result, 4, (long_to_integer (info -> cbFile)));
+  VECTOR_SET (result, 4, (ulong_to_integer (info -> cbFile)));
   {
     unsigned int attr = (info -> attrFile);
+    SCHEME_OBJECT modes = (allocate_string (5));
     char * s = ((char *) (STRING_LOC (modes, 0)));
     (s[0]) = (((attr & FILE_DIRECTORY) != 0) ? 'd' : '-');
     (s[1]) = (((attr & FILE_READONLY)  != 0) ? 'r' : '-');
     (s[2]) = (((attr & FILE_HIDDEN)    != 0) ? 'h' : '-');
     (s[3]) = (((attr & FILE_SYSTEM)    != 0) ? 's' : '-');
     (s[4]) = (((attr & FILE_ARCHIVED)  != 0) ? 'a' : '-');
+    VECTOR_SET (result, 5, modes);
+    VECTOR_SET (result, 6, (ulong_to_integer (attr)));
   }
-  VECTOR_SET (result, 5, modes);
+  VECTOR_SET (result, 7, (ulong_to_integer (info -> cbFileAlloc)));
   PRIMITIVE_RETURN (result);
 }
-
+\f
 DEFINE_PRIMITIVE ("DRIVE-TYPE", Prim_drive_type, 1, 1, 0)
 {
   SCHEME_OBJECT arg;
@@ -388,15 +374,15 @@ DEFINE_PRIMITIVE ("CURRENT-PID", Prim_current_pid, 0, 0,
   "Return Scheme's PID.")
 {
   PRIMITIVE_HEADER (0);
-  PRIMITIVE_RETURN (long_to_integer (OS2_scheme_pid));
+  PRIMITIVE_RETURN (ulong_to_integer (OS2_scheme_pid));
 }
 
 DEFINE_PRIMITIVE ("DOS-QUERY-MEMORY", Prim_dos_query_memory, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
   {
-    ULONG start = (arg_nonnegative_integer (1));
-    ULONG length = (arg_nonnegative_integer (2));
+    ULONG start = (arg_ulong_integer (1));
+    ULONG length = (arg_ulong_integer (2));
     ULONG flags;
     XTD_API_CALL
       (dos_query_mem, (((PVOID) start), (&length), (&flags)),

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 9f075fb104064e43c1689245a832ea33aad83ef8..4bf6fd4d936cfcdb88fc347fcaa7073bc1ee4490 100644 (file)
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.23 1995/10/28 01:15:54 cph Exp $
+$Id: os2prm.scm,v 1.24 1995/10/31 08:05:02 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -173,20 +173,19 @@ MIT in each case. |#
 (define file-attributes-direct file-attributes)
 (define file-attributes-indirect file-attributes)
 
-(define-structure (file-attributes
-                  (type vector)
-                  (constructor #f)
-                  (conc-name file-attributes/))
-  (type false read-only true)
-  (access-time false read-only true)
-  (modification-time false read-only true)
-  (change-time false read-only true)
-  (length false read-only true)
-  (mode-string false read-only true))
-
-(define (file-attributes/n-links attributes)
-  attributes
-  1)
+(define-structure (file-attributes (type vector)
+                                  (constructor #f)
+                                  (conc-name file-attributes/))
+  (type #f read-only #t)
+  (access-time #f read-only #t)
+  (modification-time #f read-only #t)
+  (change-time #f read-only #t)
+  (length #f read-only #t)
+  (mode-string #f read-only #t)
+  (modes #f read-only #t)
+  (allocated-length #f read-only #t))
+
+(define (file-attributes/n-links attributes) attributes 1)
 \f
 (define (file-touch filename)
   ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))