Define some additional utility functions. (WIP)

gc.c

@@ -64,11 +64,6 @@ typedef struct seen_value
 
 /****************************************************************************/
 
-const char *const object_tag_names[16] = {
-  "special", "box",         "weak box", "pair", "fpnum", "builtin", "(6)",  "(7)",
-  "vector",  "byte string", "struct",   "will", "(12)",  "(13)",    "(14)", "(15)"
-};
-
 object_block_t object_blocks[OBJECT_BLOCK_MAX + 1];
 gc_stats_t     gc_stats;
 
@@ -1108,6 +1103,32 @@ void _release_assert(const char *str, const char *file, int line)
   abort();
 }
 
+void type_mismatch(value_t value, int expected_tag)
+{
+  static const char *const object_tag_names[16] = {
+    "special", "box",         "weak box", "pair", "fpnum", "builtin", "(6)",  "(7)",
+    "vector",  "byte string", "struct",   "will", "(12)",  "(13)",    "(14)", "(15)"
+  };
+
+  const char *actual_type;
+
+  if (is_fixnum(value))
+    actual_type = "fixnum";
+  else if (value == UNDEFINED)
+    actual_type = "undefined";
+  else if (value == NIL)
+    actual_type = "nil";
+  else if ((value == FALSE_VALUE) || (value == TRUE_VALUE))
+    actual_type = "boolean";
+  else if (value == END_PROGRAM)
+    actual_type = "#<endp>";
+  else
+    actual_type = object_tag_names[OBJECT_TAG(value)];
+
+  fprintf(stderr, "ERROR: Expected %s, found %s.\n", object_tag_names[expected_tag], actual_type);
+  abort();
+}
+
 static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
 {
   seen_value_t new_seen = { v, seen };

gc.h

@@ -211,7 +211,6 @@ typedef struct gc_stats
 ** Object Declarations
 */
 
-extern const char     *const object_tag_names[16];
 extern object_block_t  object_blocks[OBJECT_BLOCK_MAX + 1];
 extern gc_stats_t      gc_stats;
 
@@ -284,6 +283,9 @@ void fprint_gc_stats(FILE *f);
 /* Implements the release_assert() macro */
 void _release_assert(const char *str, const char *file, int line) __attribute__((noreturn));
 
+/* Provides a more informative message for type check failures */
+void type_mismatch(value_t value, int expected_tag) __attribute__((noreturn));
+
 /* To be provided by the main application */
 void out_of_memory(void);
 
@@ -409,16 +411,7 @@ static inline object_t *_get_typed_object(value_t value, int tag)
 {
   if (!is_object_type(value, tag))
   {
-    if (is_fixnum(value))
-    {
-      fprintf(stderr, "ERROR: Expected %s, found fixnum.\n", object_tag_names[tag]);
-    }
-    else
-    {
-      fprintf(stderr, "ERROR: Expected %s, found %s.\n",
-          object_tag_names[tag], object_tag_names[OBJECT_TAG(value)]);
-    }
-    release_assert(is_object_type(value, tag));
+    type_mismatch(value, tag);
   }
   return &object_blocks[OBJECT_BLOCK(value)].objects[OBJECT_INDEX(value)];
 }

src/compiler.rls

@@ -1034,8 +1034,10 @@
       (let ([first-form (call-with-parameters read
                          (list current-read-eof-handler done))])
         (if (and (pair? first-form)
-                 (eq? (first first-form) 'load))
-            (cons (read-module-from-path (second first-form)) (read-rest))
+                 (eq? (first first-form) 'load)
+                 (pair? (cdr first-form)))
+            (let ([mod (read-module-from-path (second first-form))])
+              (cons mod (read-rest)))
             (cons first-form (read-rest))))))
 
   (cons 'begin
@@ -1043,8 +1045,10 @@
      (list current-read-syntax-error-handler syntax-error-handler))))
 
 (define (read-module-from-path path)
+  (display path (current-error-port)) (write-char #\Newline (current-error-port)) ;debug
   (let ([oldcwd (posix-getcwd)]
         [port (open-posix-input-port path)])
+    (display oldcwd (current-error-port)) (write-char #\Newline (current-error-port)) ;debug
     (posix-chdir (dirname path))
     (call-with-parameters
      (lambda ()

src/lib/hash-table.rls

@@ -1,4 +1,4 @@
-;; Requires: make-structure equal?
+;; Requires: make-structure equal? copy-vector
 
 (define (caar x) (car (car x)))
 (define (cdar x) (cdr (car x)))
@@ -24,6 +24,14 @@
 (define (hash-table-buckets ht)        (struct-ref  (type-check s:hash-table ht) 3))
 (define (set-hash-table-buckets! ht v) (struct-set! (type-check s:hash-table ht) 3 v))
 
+(define (copy-hash-table from-ht)
+  (let ([to-ht (make-struct s:hash-table)])
+    (struct-set! to-ht 0 (hash-table-eq-function          from-ht))
+    (struct-set! to-ht 1 (hash-table-hash-function        from-ht))
+    (struct-set! to-ht 2 (hash-table-entries              from-ht))
+    (struct-set! to-ht 3 (copy-vector (hash-table-buckets from-ht)))
+    to-ht))
+
 (define (hash-table-key->index ht key)
   (let* ([hash  ((hash-table-hash-function ht) key)]
          [limit (vector-size (hash-table-buckets ht))]

src/lib/util.rls

@@ -13,6 +13,21 @@
       (drop (fix- n 1) (cdr lst))
       lst))
 
+(define (vector-slice vec start [end (vector-size vec)])
+  (let* ([real-end (if (fix> end (vector-size vec))
+                       (vector-size vec)
+                       end)]
+         [len (if (fix> start real-end) 0 (fix- real-end start))]
+         [out (make-vector len undefined)])
+    (let iter ([i 0])
+      (when (fix< i len)
+        (vector-set! out i (vector-ref vec (fix+ i start)))
+        (iter (fix+ i 1))))
+    out))
+
+(define (copy-vector vec)
+  (vector-slice vec 0))
+
 (define (byte-substring str start [end (byte-string-size str)])
   (let* ([real-end (if (fix> end (byte-string-size str))
                        (byte-string-size str)

src/test-util.rls

@@ -23,5 +23,7 @@
  (dirname "a//b/c/d")
  (dirname "a/b/c/d/")
  (dirname "a/b/c/d///")
+ (vector-slice #(1 2 3 4 5) 0)
+ (vector-slice #(1 2 3 4 5) 2 2)
  )