On Tue, Oct 14, 2008 at 4:08 PM, Jörg F. Wittenberger
<[EMAIL PROTECTED]> wrote:
>
> The former one (within the block comment) binds "condition?" etc. to
> "unbound value".
>
> How is that possible?
>
With the attached file I get:
% bin/csi -s srfi-35.scm
#<procedure (condition? obj)>
% bin/csc srfi-35.scm -o xxx
% xxx
#<procedure (srfi-35#condition? obj176)>
cheers,
felix
(require-library srfi-1)
(module
;; SRFI 35 reference implementation, dancing around a name clash with
;; chicken3. TODO remove the dance, that's what the module system is
;; supposed be to good for. Also clean up the export list!
srfi-35 *
(import scheme
(except chicken condition?)
(rename chicken (condition? orig.condition?))
srfi-1)
(define-record-type :condition-type
(really-make-condition-type name supertype fields all-fields)
condition-type?
(name condition-type-name)
(supertype condition-type-supertype)
(fields condition-type-fields)
(all-fields condition-type-all-fields))
(define (make-condition-type name supertype fields)
(if (not (symbol? name))
(error "make-condition-type: name is not a symbol"
name))
(if (not (condition-type? supertype))
(error "make-condition-type: supertype is not a condition type"
supertype))
(if (not
(null? (lset-intersection eq?
(condition-type-all-fields supertype)
fields)))
(error "duplicate field name" ))
(really-make-condition-type name
supertype
fields
(append (condition-type-all-fields supertype)
fields)))
(define-syntax define-condition-type
(syntax-rules ()
((define-condition-type ?name ?supertype ?predicate
(?field1 ?accessor1) ...)
(begin
(define ?name
(make-condition-type '?name
?supertype
'(?field1 ...)))
(define (?predicate thing)
(and (condition? thing)
(condition-has-type? thing ?name)))
(define (?accessor1 condition)
(condition-ref (extract-condition condition ?name)
'?field1))
...))))
(define (condition-subtype? subtype supertype)
(let recur ((subtype subtype))
(cond ((not subtype) #f)
((eq? subtype supertype) #t)
(else
(recur (condition-type-supertype subtype))))))
(define (condition-type-field-supertype condition-type field)
(let loop ((condition-type condition-type))
(cond ((not condition-type) #f)
((memq field (condition-type-fields condition-type))
condition-type)
(else
(loop (condition-type-supertype condition-type))))))
;; The type-field-alist is of the form
;; ((<type> (<field-name> . <value>) ...) ...)
(define-record-type :condition
(really-make-condition type-field-alist)
condition?*
(type-field-alist condition-type-field-alist))
(define chicken-condition? orig.condition?)
(define (condition? obj)
(or (condition?* obj) (chicken-condition? obj)))
(define (make-condition type . field-plist)
(let ((alist (let label ((plist field-plist))
(if (null? plist)
'()
(cons (cons (car plist)
(cadr plist))
(label (cddr plist)))))))
(if (not (lset= eq?
(condition-type-all-fields type)
(map car alist)))
(error "condition fields don't match condition type"))
(really-make-condition (list (cons type alist)))))
(define (condition-has-type? condition type)
(and (condition?* condition)
(any (lambda (has-type)
(condition-subtype? has-type type))
(condition-types condition))))
(define (condition-ref condition field)
(type-field-alist-ref (condition-type-field-alist condition)
field))
(define (type-field-alist-ref type-field-alist field)
(let loop ((type-field-alist type-field-alist))
(cond ((null? type-field-alist)
(error "type-field-alist-ref: field not found"
type-field-alist field))
((assq field (cdr (car type-field-alist)))
=> cdr)
(else
(loop (cdr type-field-alist))))))
(define (make-compound-condition condition-1 . conditions)
(really-make-condition
(apply append (map condition-type-field-alist
(cons condition-1 conditions)))))
(define (extract-condition condition type)
(let ((entry (find (lambda (entry)
(condition-subtype? (car entry) type))
(condition-type-field-alist condition))))
(if (not entry)
(error "extract-condition: invalid condition type"
condition type))
(really-make-condition
(list (cons type
(map (lambda (field)
(assq field (cdr entry)))
(condition-type-all-fields type)))))))
(define-syntax condition
(syntax-rules ()
((condition (?type1 (?field1 ?value1) ...) ...)
(type-field-alist->condition
(list
(cons ?type1
(list (cons '?field1 ?value1) ...))
...)))))
(define (type-field-alist->condition type-field-alist)
(really-make-condition
(map (lambda (entry)
(cons (car entry)
(map (lambda (field)
(or (assq field (cdr entry))
(cons field
(type-field-alist-ref type-field-alist field))))
(condition-type-all-fields (car entry)))))
type-field-alist)))
(define (condition-types condition)
(if (condition?* condition)
(map car (condition-type-field-alist condition))
'()))
(define (check-condition-type-field-alist the-type-field-alist)
(let loop ((type-field-alist the-type-field-alist))
(if (not (null? type-field-alist))
(let* ((entry (car type-field-alist))
(type (car entry))
(field-alist (cdr entry))
(fields (map car field-alist))
(all-fields (condition-type-all-fields type)))
(for-each (lambda (missing-field)
(let ((supertype
(condition-type-field-supertype type missing-field)))
(if (not
(any (lambda (entry)
(let ((type (car entry)))
(condition-subtype? type supertype)))
the-type-field-alist))
(error "missing field in condition construction"
type
missing-field))))
(lset-difference eq? all-fields fields))
(loop (cdr type-field-alist))))))
(define &condition (really-make-condition-type '&condition
#f
'()
'()))
(define-condition-type &message &condition
message-condition?
(message condition-message))
(define-condition-type &serious &condition serious-condition?)
(define-condition-type &error &serious error?)
)
(import (prefix srfi-35 srfi-35:))
(print srfi-35:condition?)
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
