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
PACKAGE = ikarus
STRIP =
VERSION = prerelease-0
VERSION = prerelease-0.01
am__include = include
am__quote =
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.
PACKAGE=ikarus
VERSION=prerelease-0
VERSION=prerelease-0.01
cat >>confdefs.h <<_ACEOF

2
configure.ac
View File

@ -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

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)
(reset-input-port! (console-input-port))
(flush-output-port (console-output-port))
(display "Unhandled exception\n")
(print-condition con)
(k (void)))
(lambda ()

55
scheme/ikarus.conditions.ss
View File

@ -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))]

2
scheme/ikarus.handlers.ss
View File

@ -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)])))

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

@ -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])

8
scheme/ikarus.symbols.ss
View File

@ -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

260
scheme/makefile.ss
View File

@ -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]