diff --git a/Makefile b/Makefile index 6bf08c1..42ca391 100644 --- a/Makefile +++ b/Makefile @@ -78,7 +78,7 @@ DEPDIR = .deps INSTALL_STRIP_PROGRAM = ${SHELL} $(install_sh) -c -s PACKAGE = ikarus STRIP = -VERSION = prerelease-0 +VERSION = prerelease-0.01 am__include = include am__quote = install_sh = /Users/ikarus/Work/ikarus-scheme/install-sh diff --git a/configure b/configure index a0ebcec..2ba0c57 100755 --- a/configure +++ b/configure @@ -1653,7 +1653,7 @@ fi # Define the identity of the package. PACKAGE=ikarus - VERSION=prerelease-0 + VERSION=prerelease-0.01 cat >>confdefs.h <<_ACEOF diff --git a/configure.ac b/configure.ac index e380c15..e2908f8 100644 --- a/configure.ac +++ b/configure.ac @@ -4,7 +4,7 @@ AC_PREREQ(2.59) AC_INIT(ikarus, prerelease-0, aghuloum@cs.indiana.edu) AC_CANONICAL_SYSTEM -AM_INIT_AUTOMAKE(ikarus, prerelease-0) +AM_INIT_AUTOMAKE(ikarus, prerelease-0.01) AC_CONFIG_SRCDIR([src/]) AM_PROG_AS diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index 8e5e157..931db26 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/ikarus.cafe.ss b/scheme/ikarus.cafe.ss index 88ebdb0..50e7911 100644 --- a/scheme/ikarus.cafe.ss +++ b/scheme/ikarus.cafe.ss @@ -57,6 +57,7 @@ description: (lambda (con) (reset-input-port! (console-input-port)) (flush-output-port (console-output-port)) + (display "Unhandled exception\n") (print-condition con) (k (void))) (lambda () diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss index 85b5f99..194577b 100644 --- a/scheme/ikarus.conditions.ss +++ b/scheme/ikarus.conditions.ss @@ -58,6 +58,8 @@ ) (import + (rnrs records inspection) + (rnrs records procedural) (only (rnrs) record-type-descriptor record-constructor-descriptor record-predicate) (only (ikarus records procedural) rtd? rtd-subtype?) (except (ikarus) define-condition-type condition? simple-conditions @@ -65,6 +67,16 @@ print-condition ;;; more junk + + &condition &message &warning &serious &error &violation + &assertion &irritants &who &non-continuable + &implementation-restriction &lexical &syntax &undefined + &i/o &i/o-read &i/o-write &i/o-invalid-position + &i/o-filename &i/o-file-protection &i/o-file-is-read-only + &i/o-file-already-exists &i/o-file-does-not-exist + &i/o-port &i/o-decoding &i/o-encoding &no-infinities + &no-nans + make-message-condition message-condition? condition-message make-warning warning? make-serious-condition serious-condition? make-error @@ -110,8 +122,8 @@ (sealed #t) (opaque #t)) - (define (condition? x) - (or (&condition? x) + (define (condition? x) + (or (&condition? x) (compound-condition? x))) (define condition @@ -303,10 +315,43 @@ (define print-condition (let () + (define (print-simple-condition x p) + (let ([rtd (record-rtd x)]) + (let ([name (record-type-name rtd)]) + (display name p)) + (let ([v (record-type-field-names rtd)]) + (case (vector-length v) + [(1) + (display ": " p) + (write ((record-accessor rtd 0) x) p)] + [else + (let f ([i 0]) + (unless (= i (vector-length v)) + (display " " p) + (display (vector-ref v i) p) + (display "=" p) + (write ((record-accessor rtd i) x) p) + (f (+ i 1))))])) + (newline p))) (define (print-condition x p) - (display "CONDITION: " p) - (write x p) - (newline p)) + (cond + [(condition? x) + (let ([ls (simple-conditions x)]) + (if (null? ls) + (display "Condition object with no further information\n" p) + (begin + (display " Condition components:\n") + (let f ([ls ls] [i 1]) + (unless (null? ls) + (display " " p) + (display i p) + (display ". " p) + (print-simple-condition (car ls) p) + (f (cdr ls) (+ i 1)))))))] + [else + (display "Non-condition object: " p) + (write x p) + (newline p)])) (case-lambda [(x) (print-condition x (console-output-port))] diff --git a/scheme/ikarus.handlers.ss b/scheme/ikarus.handlers.ss index 134b8fe..606ec78 100644 --- a/scheme/ikarus.handlers.ss +++ b/scheme/ikarus.handlers.ss @@ -65,7 +65,7 @@ [(symbol? x) (if (symbol-bound? x) (error 'top-level-value-error "BUG in ~s" x) - (error #f "~a is unbound" x))] + (error #f "unbound" (string->symbol (symbol->string x))))] [else (error 'top-level-value "~s is not a symbol" x)]))) diff --git a/scheme/ikarus.records.procedural.ss b/scheme/ikarus.records.procedural.ss index 434b0ca..a5505f6 100644 --- a/scheme/ikarus.records.procedural.ss +++ b/scheme/ikarus.records.procedural.ss @@ -10,7 +10,11 @@ (import (except (ikarus) record-constructor record-predicate record? record-type-name - record-type-parent record-type-descriptor? + record-type-parent record-type-descriptor? record-rtd + record-type-uid record-type-sealed? record-type-opaque? + record-type-generative? make-record-type-descriptor + make-record-constructor-descriptor record-accessor + record-mutator record-type-field-names record-field-mutable? rtd? rtd-subtype?) (ikarus system $structs)) @@ -332,7 +336,7 @@ (lambda (x) (cond [($struct/rtd? x rtd) #t] - [($struct x) + [($struct? x) (let ([xrtd ($struct-rtd x)]) (and (rtd? xrtd) (let f ([prtd (rtd-parent xrtd)] [rtd rtd]) diff --git a/scheme/ikarus.symbols.ss b/scheme/ikarus.symbols.ss index 1b73639..27d0f29 100644 --- a/scheme/ikarus.symbols.ss +++ b/scheme/ikarus.symbols.ss @@ -39,7 +39,9 @@ (error 'top-level-value "~s is not a symbol" x)) (let ([v ($symbol-value x)]) (when ($unbound-object? v) - (error 'eval "~a is unbound" x)) + (error 'eval "unbound variable" + (string->symbol + (symbol->string x)))) v))) (define top-level-bound? @@ -89,7 +91,9 @@ (lambda args (let ([v ($symbol-value x)]) (if ($unbound-object? v) - (error 'eval "~a is unbound" x) + (error 'eval "unbound variable" + (string->symbol + (symbol->string x))) (error 'apply "~s is not a procedure" v))))))))) (define string->symbol diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 96140e9..c52f6e0 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -570,7 +570,7 @@ [apply i r ba se] [asin i r ba se] [assert i r ba] - [assertion-violation r ba] + [assertion-violation i r ba] [atan i r ba se] [boolean=? i r ba] [boolean? i r ba se] @@ -829,12 +829,12 @@ [fltruncate i r fl] [flzero? i r fl] [real->flonum r fl] - [make-no-infinities-violation r fl] - [make-no-nans-violation r fl] - [&no-infinities r fl] - [no-infinities-violation? r fl] - [&no-nans r fl] - [no-nans-violation? r fl] + [make-no-infinities-violation i r fl] + [make-no-nans-violation i r fl] + [&no-infinities i r fl] + [no-infinities-violation? i r fl] + [&no-nans i r fl] + [no-nans-violation? i r fl] [bytevector->sint-list i r bv] [bytevector->u8-list i r bv] [bytevector->uint-list i r bv] @@ -894,58 +894,58 @@ [utf16->string r bv] [utf32->string r bv] [print-condition i] - [condition? r co] - [&assertion r co] - [assertion-violation? r co] - [&condition r co] - [condition r co] - [condition-accessor r co] - [condition-irritants r co] - [condition-message r co] - [condition-predicate r co] - [condition-who r co] - [define-condition-type r co] - [&error r co] - [error? r co] - [&implementation-restriction r co] - [implementation-restriction-violation? r co] - [&irritants r co] - [irritants-condition? r co] - [&lexical r co] - [lexical-violation? r co] - [make-assertion-violation r co] - [make-error r co] - [make-implementation-restriction-violation r co] - [make-irritants-condition r co] - [make-lexical-violation r co] - [make-message-condition r co] - [make-non-continuable-violation r co] - [make-serious-condition r co] - [make-syntax-violation r co] - [make-undefined-violation r co] - [make-violation r co] - [make-warning r co] - [make-who-condition r co] - [&message r co] - [message-condition? r co] - [&non-continuable r co] - [non-continuable-violation? r co] - [&serious r co] - [serious-condition? r co] - [simple-conditions r co] - [&syntax r co] - [syntax-violation r co sc] - [syntax-violation-form r co] - [syntax-violation-subform r co] - [syntax-violation? r co] - [&undefined r co] - [undefined-violation? r co] - [&violation r co] - [violation? r co] - [&warning r co] - [warning? r co] - [&who r co] - [who-condition? r co] + [condition? i r co] + [&assertion i r co] + [assertion-violation? i r co] + [&condition i r co] + [condition i r co] + [condition-accessor i r co] + [condition-irritants i r co] + [condition-message i r co] + [condition-predicate i r co] + [condition-who i r co] + [define-condition-type i r co] + [&error i r co] + [error? i r co] + [&implementation-restriction i r co] + [implementation-restriction-violation? i r co] + [&irritants i r co] + [irritants-condition? i r co] + [&lexical i r co] + [lexical-violation? i r co] + [make-assertion-violation i r co] + [make-error i r co] + [make-implementation-restriction-violation i r co] + [make-irritants-condition i r co] + [make-lexical-violation i r co] + [make-message-condition i r co] + [make-non-continuable-violation i r co] + [make-serious-condition i r co] + [make-syntax-violation i r co] + [make-undefined-violation i r co] + [make-violation i r co] + [make-warning i r co] + [make-who-condition i r co] + [&message i r co] + [message-condition? i r co] + [&non-continuable i r co] + [non-continuable-violation? i r co] + [&serious i r co] + [serious-condition? i r co] + [simple-conditions i r co] + [&syntax i r co] + [syntax-violation i r co sc] + [syntax-violation-form i r co] + [syntax-violation-subform i r co] + [syntax-violation? i r co] + [&undefined i r co] + [undefined-violation? i r co] + [&violation i r co] + [violation? i r co] + [&warning i r co] + [warning? i r co] + [&who i r co] + [who-condition? i r co] [case-lambda i r ct] [do i r ct se ne] [unless i r ct] @@ -966,9 +966,9 @@ [make-enumeration r en] [environment i ev] [eval i ev se] - [raise r ex] - [raise-continuable r ex] - [with-exception-handler r ex] + [raise i r ex] + [raise-continuable i r ex] + [with-exception-handler i r ex] [guard r ex] [binary-port? r ip] [buffer-mode i r ip] @@ -1028,33 +1028,33 @@ [get-string-n r ip] [get-string-n! r ip] [get-u8 r ip] - [&i/o r ip is fi] - [&i/o-decoding r ip] - [i/o-decoding-error? r ip] - [&i/o-encoding r ip] - [i/o-encoding-error-char r ip] - [i/o-encoding-error? r ip] - [i/o-error-filename r ip is fi] - [i/o-error-port r ip is fi] - [i/o-error? r ip is fi] - [&i/o-file-already-exists r ip is fi] - [i/o-file-already-exists-error? r ip is fi] - [&i/o-file-does-not-exist r ip is fi] - [i/o-file-does-not-exist-error? r ip is fi] - [&i/o-file-is-read-only r ip is fi] - [i/o-file-is-read-only-error? r ip is fi] - [&i/o-file-protection r ip is fi] - [i/o-file-protection-error? r ip is fi] - [&i/o-filename r ip is fi] - [i/o-filename-error? r ip is fi] - [&i/o-invalid-position r ip is fi] - [i/o-invalid-position-error? r ip is fi] - [&i/o-port r ip is fi] - [i/o-port-error? r ip is fi] - [&i/o-read r ip is fi] - [i/o-read-error? r ip is fi] - [&i/o-write r ip is fi] - [i/o-write-error? r ip is fi] + [&i/o i r ip is fi] + [&i/o-decoding i r ip] + [i/o-decoding-error? i r ip] + [&i/o-encoding i r ip] + [i/o-encoding-error-char i r ip] + [i/o-encoding-error? i r ip] + [i/o-error-filename i r ip is fi] + [i/o-error-port i r ip is fi] + [i/o-error? i r ip is fi] + [&i/o-file-already-exists i r ip is fi] + [i/o-file-already-exists-error? i r ip is fi] + [&i/o-file-does-not-exist i r ip is fi] + [i/o-file-does-not-exist-error? i r ip is fi] + [&i/o-file-is-read-only i r ip is fi] + [i/o-file-is-read-only-error? i r ip is fi] + [&i/o-file-protection i r ip is fi] + [i/o-file-protection-error? i r ip is fi] + [&i/o-filename i r ip is fi] + [i/o-filename-error? i r ip is fi] + [&i/o-invalid-position i r ip is fi] + [i/o-invalid-position-error? i r ip is fi] + [&i/o-port i r ip is fi] + [i/o-port-error? i r ip is fi] + [&i/o-read i r ip is fi] + [i/o-read-error? i r ip is fi] + [&i/o-write i r ip is fi] + [i/o-write-error? i r ip is fi] [lookahead-char r ip] [lookahead-u8 r ip] [make-bytevector i r bv] @@ -1064,18 +1064,18 @@ [make-custom-textual-input-port r ip] [make-custom-textual-input/output-port r ip] [make-custom-textual-output-port r ip] - [make-i/o-decoding-error r ip] - [make-i/o-encoding-error r ip] - [make-i/o-error r ip is fi] - [make-i/o-file-already-exists-error r ip is fi] - [make-i/o-file-does-not-exist-error r ip is fi] - [make-i/o-file-is-read-only-error r ip is fi] - [make-i/o-file-protection-error r ip is fi] - [make-i/o-filename-error r ip is fi] - [make-i/o-invalid-position-error r ip is fi] - [make-i/o-port-error r ip is fi] - [make-i/o-read-error r ip is fi] - [make-i/o-write-error r ip is fi] + [make-i/o-decoding-error i r ip] + [make-i/o-encoding-error i r ip] + [make-i/o-error i r ip is fi] + [make-i/o-file-already-exists-error i r ip is fi] + [make-i/o-file-does-not-exist-error i r ip is fi] + [make-i/o-file-is-read-only-error i r ip is fi] + [make-i/o-file-protection-error i r ip is fi] + [make-i/o-filename-error i r ip is fi] + [make-i/o-invalid-position-error i r ip is fi] + [make-i/o-port-error i r ip is fi] + [make-i/o-read-error i r ip is fi] + [make-i/o-write-error i r ip is fi] [latin-1-codec i r ip] [make-transcoder i r ip] [native-eol-style i r ip] @@ -1133,19 +1133,19 @@ [write-char i r is se] [call-with-input-file i r is se] [call-with-output-file i r is se] - [hashtable-clear! r ht] - [hashtable-contains? r ht] + [hashtable-clear! i r ht] + [hashtable-contains? i r ht] [hashtable-copy r ht] - [hashtable-delete! r ht] + [hashtable-delete! i r ht] [hashtable-entries r ht] - [hashtable-keys r ht] - [hashtable-mutable? r ht] - [hashtable-ref r ht] - [hashtable-set! r ht] - [hashtable-size r ht] - [hashtable-update! r ht] - [hashtable? r ht] - [make-eq-hashtable r ht] + [hashtable-keys i r ht] + [hashtable-mutable? i r ht] + [hashtable-ref i r ht] + [hashtable-set! i r ht] + [hashtable-size i r ht] + [hashtable-update! i r ht] + [hashtable? i r ht] + [make-eq-hashtable i r ht] [make-eqv-hashtable r ht] [hashtable-hash-function r ht] [make-hashtable r ht] @@ -1167,27 +1167,27 @@ [parent i r rs] [parent-rtd i r rs] [protocol i r rs] - [record-constructor-descriptor r rs] + [record-constructor-descriptor i r rs] [record-type-descriptor i r rs] [sealed i r rs] [nongenerative i r rs] - [record-field-mutable? r ri] - [record-rtd r ri] - [record-type-field-names r ri] - [record-type-generative? r ri] - [record-type-name r ri] - [record-type-opaque? r ri] - [record-type-parent r ri] - [record-type-sealed? r ri] - [record-type-uid r ri] - [record? r ri] - [make-record-constructor-descriptor r rp] - [make-record-type-descriptor r rp] - [record-accessor r rp] - [record-constructor r rp] - [record-mutator r rp] - [record-predicate r rp] - [record-type-descriptor? r rp] + [record-field-mutable? i r ri] + [record-rtd i r ri] + [record-type-field-names i r ri] + [record-type-generative? i r ri] + [record-type-name i r ri] + [record-type-opaque? i r ri] + [record-type-parent i r ri] + [record-type-sealed? i r ri] + [record-type-uid i r ri] + [record? i r ri] + [make-record-constructor-descriptor i r rp] + [make-record-type-descriptor i r rp] + [record-accessor i r rp] + [record-constructor i r rp] + [record-mutator i r rp] + [record-predicate i r rp] + [record-type-descriptor? i r rp] [bound-identifier=? i r sc] [datum->syntax i r sc] [syntax i r sc]