194 lines
5.5 KiB
Scheme
194 lines
5.5 KiB
Scheme
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
|
|
|
|
|
|
; Records & (tagged) Unions
|
|
;
|
|
; Can we arrange to pass records as a separate type from the including union?
|
|
; Probably not. This introduces type relations that have to be satisified.
|
|
; No coercions are needed so it would be much simpler than before. Unification
|
|
; would have to find meets. I guess that it would be doable, but not for now.
|
|
;
|
|
; The only records that have tags are those that are part of a multi-record
|
|
; union. If a record is not part of a union it does not need a tag field.
|
|
;
|
|
; The simplest thing is probably to only have tagged unions, with stand-alone
|
|
; records being a degenerate case (to be added later).
|
|
|
|
; Data types
|
|
|
|
; Representation of union types.
|
|
|
|
(define-record-type union-type
|
|
(name ; name of the data type
|
|
variants ; what this can be
|
|
)
|
|
())
|
|
|
|
(define-record-discloser type/union-type
|
|
(lambda (union)
|
|
(list 'union-type (union-type-name dtype))))
|
|
|
|
; Record variants of unions
|
|
|
|
(define-record-type record-type
|
|
(index ; index of this record in parent union
|
|
predicate ; name of the predicate ; only at top-level
|
|
constructor ; name of the constructor
|
|
)
|
|
(fields ; filled in later because of circularity
|
|
constructor-args)) ; fields passed to the constructor
|
|
|
|
(define-record-discloser type/record-type
|
|
(lambda (rtype)
|
|
(list 'record-type (record-type-constructor rtype))))
|
|
|
|
; Fields of record types.
|
|
|
|
(define-record-type record-field
|
|
(record-type
|
|
name
|
|
type
|
|
)
|
|
())
|
|
|
|
; Global table of record types. Since we compile to a single C file the
|
|
; record types used within a single computation must have distinct names.
|
|
; (This should really be a fluid.)
|
|
; Or we could make up names as necessary.
|
|
|
|
(define *record-type-table* (make-symbol-table))
|
|
|
|
(define (reset-record-data!)
|
|
(set! *record-type-table* (make-symbol-table)))
|
|
|
|
(define (get-record-type id)
|
|
(cond ((table-ref *record-type-table* id)
|
|
=> identity)
|
|
(else
|
|
(error "no record type ~S" id))))
|
|
|
|
(define (all-record-types)
|
|
(table->entry-list *record-type-table*))
|
|
|
|
(define (lookup-union-type id)
|
|
(table-ref *record-type-table* id))
|
|
|
|
; Construction a record type. This gets the name, the list of fields whose
|
|
; initial values are passed to the constructor, and the field specifications.
|
|
; Each field specification consists of a name and a type.
|
|
|
|
(define (make-record-type id constructor-args specs)
|
|
(let ((rt (record-type-maker id)))
|
|
(if (table-ref *record-type-table* id)
|
|
(user-error "multiple definitions of record type ~S" id))
|
|
(table-set! *record-type-table* id rt)
|
|
(set-record-type-fields! rt (map (lambda (spec)
|
|
(record-field-maker
|
|
rt
|
|
(car spec)
|
|
(expand-type-spec (cadr spec))))
|
|
specs))
|
|
(set-record-type-constructor-args! rt
|
|
(map (lambda (name)
|
|
(get-record-type-field id name))
|
|
constructor-args))
|
|
rt))
|
|
|
|
; Return the field record for FIELD-ID in record-type TYPE-ID.
|
|
|
|
(define (get-record-type-field type-id field-id)
|
|
(let ((rtype (get-record-type type-id)))
|
|
(cond ((any (lambda (field)
|
|
(eq? field-id (record-field-name field)))
|
|
(record-type-fields rtype))
|
|
=> identity)
|
|
(else
|
|
(user-error "~S is not a field of ~S" field-id rtype)))))
|
|
|
|
; The macro expander for DEFINE-RECORD-TYPE.
|
|
;
|
|
; (define-record-type <id> <type-id>
|
|
; (<constructor> . <field-names>)
|
|
; (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
|
|
;
|
|
; The <type-id> is used only by Pre-Scheme-in-Scheme.
|
|
|
|
(define (expand-define-record-type exp r c)
|
|
(let ((id (cadr exp))
|
|
(maker (cadddr exp))
|
|
(fields (cddddr exp)))
|
|
(let ((rt (make-record-type id (cdr maker) fields)))
|
|
`(,(r 'begin)
|
|
(,(r 'define) ,maker
|
|
(,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
|
|
(,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
|
|
(,(r 'begin)
|
|
. ,(map (lambda (name)
|
|
`(,(r 'record-set!) ,(r id) ,name ',id ',name))
|
|
(cdr maker))))
|
|
,(r id)))
|
|
,@(map (lambda (field)
|
|
`(,(r 'define) (,(caddr field) ,(r id))
|
|
(,(r 'record-ref) ,(r id) ',id ',(car field))))
|
|
fields)
|
|
,@(map (lambda (field)
|
|
`(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
|
|
(,(r 'record-set!)
|
|
,(r id) ,(r 'x)',id ',(car field))))
|
|
(filter (lambda (spec)
|
|
(not (null? (cdddr spec))))
|
|
fields))))))
|
|
|
|
|
|
; In C.
|
|
;
|
|
; All unions are cast to a single type. All records that are part of unions
|
|
; have an initial tag field.
|
|
;
|
|
;struct datatypeX { int tagX; };
|
|
;
|
|
;#define NULL_TAGX 0
|
|
;#define PAIR_TAGX 1
|
|
;
|
|
;struct pair {
|
|
; int tagX;
|
|
; long car;
|
|
; struct datatypeX *cdr;
|
|
;};
|
|
;
|
|
;struct datatypeX nullX = { NULL_TAGX }, *null = &nullX;
|
|
;
|
|
;struct datatypeX *cons(unsigned char, struct datatypeX*);
|
|
;struct datatypeX *reverseB(struct datatypeX*);
|
|
;char memberP(struct datatypeX*, long);
|
|
;void init(void);
|
|
;
|
|
;struct datatypeX *cons(unsigned char car_0X, struct datatypeX *cdr_1X)
|
|
;{
|
|
; struct pair *pair_2X;
|
|
; {pair_2X = (struct pair *)malloc(sizeof(struct pair));
|
|
; if ((NULL == pair_2X)) {
|
|
; return (struct datatypeX *)pair_2X;}
|
|
; else {
|
|
; pair_2X->tagX = PAIR_TAGX;
|
|
; pair_2X->car = (((unsigned long) car_0X));
|
|
; pair_2X->cdr = cdr_1X;
|
|
; return (struct datatypeX *)pair_2X;}}}
|
|
;
|
|
;char memberP(struct datatypeX *list_7X, long x_8X)
|
|
;{
|
|
; struct datatypeX *arg0K0;
|
|
; struct datatypeX *list_9X;
|
|
; {arg0K0 = list_7X;
|
|
; goto L169;}
|
|
; L169: {
|
|
; list_9X = arg0K0;
|
|
; if ((list_9X->tagX == NULL_TAGX)) {
|
|
; return 0;}
|
|
; else {
|
|
; if ((x_8X == ((struct pair *)list_9X)->car)) {
|
|
; return 1;}
|
|
; else {
|
|
; arg0K0 = ((struct pair *)list_9X)->cdr;
|
|
; goto L169;}}}}
|