conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Fixed a bug that caused record-predicates to segfault. 

* Added condition printers.
This commit is contained in:
Abdulaziz Ghuloum 2007-10-25 02:19:53 -04:00
parent dab2b74189
commit 4141d699c5
10 changed files with 197 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -78,7 +78,7 @@ DEPDIR = .deps
INSTALL_STRIP_PROGRAM = ${SHELL} $(install_sh) -c -s INSTALL_STRIP_PROGRAM = ${SHELL} $(install_sh) -c -s
PACKAGE = ikarus PACKAGE = ikarus
STRIP = STRIP =
VERSION = prerelease-0 VERSION = prerelease-0.01
am__include = include am__include = include
am__quote = am__quote =
install_sh = /Users/ikarus/Work/ikarus-scheme/install-sh install_sh = /Users/ikarus/Work/ikarus-scheme/install-sh

2
configure vendored
View File

@ -1653,7 +1653,7 @@ fi
# Define the identity of the package. # Define the identity of the package.
PACKAGE=ikarus PACKAGE=ikarus
VERSION=prerelease-0 VERSION=prerelease-0.01
cat >>confdefs.h <<_ACEOF cat >>confdefs.h <<_ACEOF

2
configure.ac
View File

@ -4,7 +4,7 @@
AC_PREREQ(2.59) AC_PREREQ(2.59)
AC_INIT(ikarus, prerelease-0, aghuloum@cs.indiana.edu) AC_INIT(ikarus, prerelease-0, aghuloum@cs.indiana.edu)
AC_CANONICAL_SYSTEM AC_CANONICAL_SYSTEM
AM_INIT_AUTOMAKE(ikarus, prerelease-0) AM_INIT_AUTOMAKE(ikarus, prerelease-0.01)
AC_CONFIG_SRCDIR([src/]) AC_CONFIG_SRCDIR([src/])
AM_PROG_AS AM_PROG_AS

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

1
scheme/ikarus.cafe.ss
View File

@ -57,6 +57,7 @@ description:
(lambda (con) (lambda (con)
(reset-input-port! (console-input-port)) (reset-input-port! (console-input-port))
(flush-output-port (console-output-port)) (flush-output-port (console-output-port))
(display "Unhandled exception\n")
(print-condition con) (print-condition con)
(k (void))) (k (void)))
(lambda () (lambda ()

49
scheme/ikarus.conditions.ss
View File

@ -58,6 +58,8 @@
) )
(import (import
(rnrs records inspection)
(rnrs records procedural)
(only (rnrs) record-type-descriptor record-constructor-descriptor record-predicate) (only (rnrs) record-type-descriptor record-constructor-descriptor record-predicate)
(only (ikarus records procedural) rtd? rtd-subtype?) (only (ikarus records procedural) rtd? rtd-subtype?)
(except (ikarus) define-condition-type condition? simple-conditions (except (ikarus) define-condition-type condition? simple-conditions
@ -65,6 +67,16 @@
print-condition print-condition
;;; more junk ;;; 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? make-message-condition message-condition?
condition-message make-warning warning? condition-message make-warning warning?
make-serious-condition serious-condition? make-error make-serious-condition serious-condition? make-error
@ -303,10 +315,43 @@
(define print-condition (define print-condition
(let () (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) (define (print-condition x p)
(display "CONDITION: " 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) (write x p)
(newline p)) (newline p)]))
(case-lambda (case-lambda
[(x) [(x)
(print-condition x (console-output-port))] (print-condition x (console-output-port))]

2
scheme/ikarus.handlers.ss
View File

@ -65,7 +65,7 @@
[(symbol? x) [(symbol? x)
(if (symbol-bound? x) (if (symbol-bound? x)
(error 'top-level-value-error "BUG in ~s" 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 [else
(error 'top-level-value "~s is not a symbol" x)]))) (error 'top-level-value "~s is not a symbol" x)])))

8
scheme/ikarus.records.procedural.ss
View File

@ -10,7 +10,11 @@
(import (import
(except (ikarus) (except (ikarus)
record-constructor record-predicate record? record-type-name 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? record-type-field-names record-field-mutable?
rtd? rtd-subtype?) rtd? rtd-subtype?)
(ikarus system $structs)) (ikarus system $structs))
@ -332,7 +336,7 @@
(lambda (x) (lambda (x)
(cond (cond
[($struct/rtd? x rtd) #t] [($struct/rtd? x rtd) #t]
[($struct x) [($struct? x)
(let ([xrtd ($struct-rtd x)]) (let ([xrtd ($struct-rtd x)])
(and (rtd? xrtd) (and (rtd? xrtd)
(let f ([prtd (rtd-parent xrtd)] [rtd rtd]) (let f ([prtd (rtd-parent xrtd)] [rtd rtd])

8
scheme/ikarus.symbols.ss
View File

@ -39,7 +39,9 @@
(error 'top-level-value "~s is not a symbol" x)) (error 'top-level-value "~s is not a symbol" x))
(let ([v ($symbol-value x)]) (let ([v ($symbol-value x)])
(when ($unbound-object? v) (when ($unbound-object? v)
(error 'eval "~a is unbound" x)) (error 'eval "unbound variable"
(string->symbol
(symbol->string x))))
v))) v)))
(define top-level-bound? (define top-level-bound?
@ -89,7 +91,9 @@
(lambda args (lambda args
(let ([v ($symbol-value x)]) (let ([v ($symbol-value x)])
(if ($unbound-object? v) (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))))))))) (error 'apply "~s is not a procedure" v)))))))))
(define string->symbol (define string->symbol

260
scheme/makefile.ss
View File

@ -570,7 +570,7 @@
[apply i r ba se] [apply i r ba se]
[asin i r ba se] [asin i r ba se]
[assert i r ba] [assert i r ba]
[assertion-violation r ba] [assertion-violation i r ba]
[atan i r ba se] [atan i r ba se]
[boolean=? i r ba] [boolean=? i r ba]
[boolean? i r ba se] [boolean? i r ba se]
@ -829,12 +829,12 @@
[fltruncate i r fl] [fltruncate i r fl]
[flzero? i r fl] [flzero? i r fl]
[real->flonum r fl] [real->flonum r fl]
[make-no-infinities-violation r fl] [make-no-infinities-violation i r fl]
[make-no-nans-violation r fl] [make-no-nans-violation i r fl]
[&no-infinities r fl] [&no-infinities i r fl]
[no-infinities-violation? r fl] [no-infinities-violation? i r fl]
[&no-nans r fl] [&no-nans i r fl]
[no-nans-violation? r fl] [no-nans-violation? i r fl]
[bytevector->sint-list i r bv] [bytevector->sint-list i r bv]
[bytevector->u8-list i r bv] [bytevector->u8-list i r bv]
[bytevector->uint-list i r bv] [bytevector->uint-list i r bv]
@ -894,58 +894,58 @@
[utf16->string r bv] [utf16->string r bv]
[utf32->string r bv] [utf32->string r bv]
[print-condition i] [print-condition i]
[condition? r co] [condition? i r co]
[&assertion r co] [&assertion i r co]
[assertion-violation? r co] [assertion-violation? i r co]
[&condition r co] [&condition i r co]
[condition r co] [condition i r co]
[condition-accessor r co] [condition-accessor i r co]
[condition-irritants r co] [condition-irritants i r co]
[condition-message r co] [condition-message i r co]
[condition-predicate r co] [condition-predicate i r co]
[condition-who r co] [condition-who i r co]
[define-condition-type r co] [define-condition-type i r co]
[&error r co] [&error i r co]
[error? r co] [error? i r co]
[&implementation-restriction r co] [&implementation-restriction i r co]
[implementation-restriction-violation? r co] [implementation-restriction-violation? i r co]
[&irritants r co] [&irritants i r co]
[irritants-condition? r co] [irritants-condition? i r co]
[&lexical r co] [&lexical i r co]
[lexical-violation? r co] [lexical-violation? i r co]
[make-assertion-violation r co] [make-assertion-violation i r co]
[make-error r co] [make-error i r co]
[make-implementation-restriction-violation r co] [make-implementation-restriction-violation i r co]
[make-irritants-condition r co] [make-irritants-condition i r co]
[make-lexical-violation r co] [make-lexical-violation i r co]
[make-message-condition r co] [make-message-condition i r co]
[make-non-continuable-violation r co] [make-non-continuable-violation i r co]
[make-serious-condition r co] [make-serious-condition i r co]
[make-syntax-violation r co] [make-syntax-violation i r co]
[make-undefined-violation r co] [make-undefined-violation i r co]
[make-violation r co] [make-violation i r co]
[make-warning r co] [make-warning i r co]
[make-who-condition r co] [make-who-condition i r co]
[&message r co] [&message i r co]
[message-condition? r co] [message-condition? i r co]
[&non-continuable r co] [&non-continuable i r co]
[non-continuable-violation? r co] [non-continuable-violation? i r co]
[&serious r co] [&serious i r co]
[serious-condition? r co] [serious-condition? i r co]
[simple-conditions r co] [simple-conditions i r co]
[&syntax r co] [&syntax i r co]
[syntax-violation r co sc] [syntax-violation i r co sc]
[syntax-violation-form r co] [syntax-violation-form i r co]
[syntax-violation-subform r co] [syntax-violation-subform i r co]
[syntax-violation? r co] [syntax-violation? i r co]
[&undefined r co] [&undefined i r co]
[undefined-violation? r co] [undefined-violation? i r co]
[&violation r co] [&violation i r co]
[violation? r co] [violation? i r co]
[&warning r co] [&warning i r co]
[warning? r co] [warning? i r co]
[&who r co] [&who i r co]
[who-condition? r co] [who-condition? i r co]
[case-lambda i r ct] [case-lambda i r ct]
[do i r ct se ne] [do i r ct se ne]
[unless i r ct] [unless i r ct]
@ -966,9 +966,9 @@
[make-enumeration r en] [make-enumeration r en]
[environment i ev] [environment i ev]
[eval i ev se] [eval i ev se]
[raise r ex] [raise i r ex]
[raise-continuable r ex] [raise-continuable i r ex]
[with-exception-handler r ex] [with-exception-handler i r ex]
[guard r ex] [guard r ex]
[binary-port? r ip] [binary-port? r ip]
[buffer-mode i r ip] [buffer-mode i r ip]
@ -1028,33 +1028,33 @@
[get-string-n r ip] [get-string-n r ip]
[get-string-n! r ip] [get-string-n! r ip]
[get-u8 r ip] [get-u8 r ip]
[&i/o r ip is fi] [&i/o i r ip is fi]
[&i/o-decoding r ip] [&i/o-decoding i r ip]
[i/o-decoding-error? r ip] [i/o-decoding-error? i r ip]
[&i/o-encoding r ip] [&i/o-encoding i r ip]
[i/o-encoding-error-char r ip] [i/o-encoding-error-char i r ip]
[i/o-encoding-error? r ip] [i/o-encoding-error? i r ip]
[i/o-error-filename r ip is fi] [i/o-error-filename i r ip is fi]
[i/o-error-port r ip is fi] [i/o-error-port i r ip is fi]
[i/o-error? r ip is fi] [i/o-error? i r ip is fi]
[&i/o-file-already-exists r ip is fi] [&i/o-file-already-exists i r ip is fi]
[i/o-file-already-exists-error? r ip is fi] [i/o-file-already-exists-error? i r ip is fi]
[&i/o-file-does-not-exist r ip is fi] [&i/o-file-does-not-exist i r ip is fi]
[i/o-file-does-not-exist-error? r ip is fi] [i/o-file-does-not-exist-error? i r ip is fi]
[&i/o-file-is-read-only r ip is fi] [&i/o-file-is-read-only i r ip is fi]
[i/o-file-is-read-only-error? r ip is fi] [i/o-file-is-read-only-error? i r ip is fi]
[&i/o-file-protection r ip is fi] [&i/o-file-protection i r ip is fi]
[i/o-file-protection-error? r ip is fi] [i/o-file-protection-error? i r ip is fi]
[&i/o-filename r ip is fi] [&i/o-filename i r ip is fi]
[i/o-filename-error? r ip is fi] [i/o-filename-error? i r ip is fi]
[&i/o-invalid-position r ip is fi] [&i/o-invalid-position i r ip is fi]
[i/o-invalid-position-error? r ip is fi] [i/o-invalid-position-error? i r ip is fi]
[&i/o-port r ip is fi] [&i/o-port i r ip is fi]
[i/o-port-error? r ip is fi] [i/o-port-error? i r ip is fi]
[&i/o-read r ip is fi] [&i/o-read i r ip is fi]
[i/o-read-error? r ip is fi] [i/o-read-error? i r ip is fi]
[&i/o-write r ip is fi] [&i/o-write i r ip is fi]
[i/o-write-error? r ip is fi] [i/o-write-error? i r ip is fi]
[lookahead-char r ip] [lookahead-char r ip]
[lookahead-u8 r ip] [lookahead-u8 r ip]
[make-bytevector i r bv] [make-bytevector i r bv]
@ -1064,18 +1064,18 @@
[make-custom-textual-input-port r ip] [make-custom-textual-input-port r ip]
[make-custom-textual-input/output-port r ip] [make-custom-textual-input/output-port r ip]
[make-custom-textual-output-port r ip] [make-custom-textual-output-port r ip]
[make-i/o-decoding-error r ip] [make-i/o-decoding-error i r ip]
[make-i/o-encoding-error r ip] [make-i/o-encoding-error i r ip]
[make-i/o-error r ip is fi] [make-i/o-error i r ip is fi]
[make-i/o-file-already-exists-error r ip is fi] [make-i/o-file-already-exists-error i r ip is fi]
[make-i/o-file-does-not-exist-error 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 r ip is fi] [make-i/o-file-is-read-only-error i r ip is fi]
[make-i/o-file-protection-error r ip is fi] [make-i/o-file-protection-error i r ip is fi]
[make-i/o-filename-error r ip is fi] [make-i/o-filename-error i r ip is fi]
[make-i/o-invalid-position-error r ip is fi] [make-i/o-invalid-position-error i r ip is fi]
[make-i/o-port-error r ip is fi] [make-i/o-port-error i r ip is fi]
[make-i/o-read-error r ip is fi] [make-i/o-read-error i r ip is fi]
[make-i/o-write-error r ip is fi] [make-i/o-write-error i r ip is fi]
[latin-1-codec i r ip] [latin-1-codec i r ip]
[make-transcoder i r ip] [make-transcoder i r ip]
[native-eol-style i r ip] [native-eol-style i r ip]
@ -1133,19 +1133,19 @@
[write-char i r is se] [write-char i r is se]
[call-with-input-file i r is se] [call-with-input-file i r is se]
[call-with-output-file i r is se] [call-with-output-file i r is se]
[hashtable-clear! r ht] [hashtable-clear! i r ht]
[hashtable-contains? r ht] [hashtable-contains? i r ht]
[hashtable-copy r ht] [hashtable-copy r ht]
[hashtable-delete! r ht] [hashtable-delete! i r ht]
[hashtable-entries r ht] [hashtable-entries r ht]
[hashtable-keys r ht] [hashtable-keys i r ht]
[hashtable-mutable? r ht] [hashtable-mutable? i r ht]
[hashtable-ref r ht] [hashtable-ref i r ht]
[hashtable-set! r ht] [hashtable-set! i r ht]
[hashtable-size r ht] [hashtable-size i r ht]
[hashtable-update! r ht] [hashtable-update! i r ht]
[hashtable? r ht] [hashtable? i r ht]
[make-eq-hashtable r ht] [make-eq-hashtable i r ht]
[make-eqv-hashtable r ht] [make-eqv-hashtable r ht]
[hashtable-hash-function r ht] [hashtable-hash-function r ht]
[make-hashtable r ht] [make-hashtable r ht]
@ -1167,27 +1167,27 @@
[parent i r rs] [parent i r rs]
[parent-rtd i r rs] [parent-rtd i r rs]
[protocol i r rs] [protocol i r rs]
[record-constructor-descriptor r rs] [record-constructor-descriptor i r rs]
[record-type-descriptor i r rs] [record-type-descriptor i r rs]
[sealed i r rs] [sealed i r rs]
[nongenerative i r rs] [nongenerative i r rs]
[record-field-mutable? r ri] [record-field-mutable? i r ri]
[record-rtd r ri] [record-rtd i r ri]
[record-type-field-names r ri] [record-type-field-names i r ri]
[record-type-generative? r ri] [record-type-generative? i r ri]
[record-type-name r ri] [record-type-name i r ri]
[record-type-opaque? r ri] [record-type-opaque? i r ri]
[record-type-parent r ri] [record-type-parent i r ri]
[record-type-sealed? r ri] [record-type-sealed? i r ri]
[record-type-uid r ri] [record-type-uid i r ri]
[record? r ri] [record? i r ri]
[make-record-constructor-descriptor r rp] [make-record-constructor-descriptor i r rp]
[make-record-type-descriptor r rp] [make-record-type-descriptor i r rp]
[record-accessor r rp] [record-accessor i r rp]
[record-constructor r rp] [record-constructor i r rp]
[record-mutator r rp] [record-mutator i r rp]
[record-predicate r rp] [record-predicate i r rp]
[record-type-descriptor? r rp] [record-type-descriptor? i r rp]
[bound-identifier=? i r sc] [bound-identifier=? i r sc]
[datum->syntax i r sc] [datum->syntax i r sc]
[syntax i r sc] [syntax i r sc]