diff --git a/gc.c b/gc.c index 9a42797..b7effcb 100644 --- a/gc.c +++ b/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 = "#"; + 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 }; diff --git a/gc.h b/gc.h index ad6ded8..649d580 100644 --- a/gc.h +++ b/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)]; } diff --git a/src/compiler.rls b/src/compiler.rls index 2c2bfa8..4eb99f4 100644 --- a/src/compiler.rls +++ b/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 () diff --git a/src/lib/hash-table.rls b/src/lib/hash-table.rls index c0c9f2e..18c556e 100644 --- a/src/lib/hash-table.rls +++ b/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))] diff --git a/src/lib/util.rls b/src/lib/util.rls index 6f29446..61262b6 100644 --- a/src/lib/util.rls +++ b/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) diff --git a/src/test-util.rls b/src/test-util.rls index 7d84600..ea1120e 100644 --- a/src/test-util.rls +++ b/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) ) - +