(if predicate-name
(let* ((context (structure/context structure))
(tag-expression
- (close (structure/tag-expression structure) context)))
+ (close (structure/tag-expression structure) context))
+ (name (parser-context/name context)))
(case (structure/physical-type structure)
- ((RECORD)
- `((DEFINE ,predicate-name
- (,(absolute 'RECORD-PREDICATE context)
+ ((record)
+ `((define ,predicate-name
+ (,(absolute 'record-predicate context)
,(close (structure/type-descriptor structure) context)))))
- ((VECTOR)
- `((DEFINE (,predicate-name OBJECT)
- (AND (,(absolute 'VECTOR? context) OBJECT)
- (,(absolute 'NOT context)
- (,(absolute 'ZERO? context)
- (,(absolute 'VECTOR-LENGTH context) OBJECT)))
- (,(absolute 'EQ? context)
- (,(absolute 'VECTOR-REF context) OBJECT 0)
- ,tag-expression)))))
- ((LIST)
- `((DEFINE (,predicate-name OBJECT)
- (AND (,(absolute 'PAIR? context) OBJECT)
- (,(absolute 'EQ? context)
- (,(absolute 'CAR context) OBJECT)
- ,tag-expression)))))))
+ ((vector)
+ `((define (,predicate-name object)
+ (and (,(absolute 'vector? context) object)
+ (,(absolute 'not context)
+ (,(absolute 'zero? context)
+ (,(absolute 'vector-length context) object)))
+ (,(absolute 'eq? context)
+ (,(absolute 'vector-ref context) object 0)
+ ,tag-expression)))
+ (,(absolute 'register-predicate! context)
+ ,predicate-name ',name
+ '<= ,(absolute 'vector? context))))
+ ((list)
+ `((define (,predicate-name object)
+ (and (,(absolute 'pair? context) object)
+ (,(absolute 'eq? context)
+ (,(absolute 'car context) object)
+ ,tag-expression)))
+ (,(absolute 'register-predicate! context)
+ ,predicate-name ',name
+ '<= ,(absolute 'pair? context))))))
'())))
\f
(define (type-definitions structure)