guile-prescheme/ps-compiler/prescheme/record.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;;   scheme48-1.9.2/ps-compiler/prescheme/record.scm
;;;
;;; Records that translate into C structs.
;;;
;;; Representation of record types.

(define-module (ps-compiler prescheme record)
  #:use-module (srfi srfi-9)
  #:use-module (prescheme scheme48)
  #:use-module (prescheme record-discloser)
  #:use-module (ps-compiler prescheme type)
  #:use-module (ps-compiler util util)
  #:export (reset-record-data!
            all-record-types
            get-record-type
            get-record-type-field
            record-field-record-type
            record-field-name
            record-field-type
            lookup-record-type)
  #:replace (record-type-name
             record-type-fields))

(define-record-type :record-type
  (really-make-record-type name)
  record-type?
  (name record-type-name)
  ;; FIELDS and CONSTRUCTOR-ARGS are filled in later because of circularity
  (fields record-type-fields set-record-type-fields!)
  (constructor-args                     ; fields passed to the constructor
   record-type-constructor-args set-record-type-constructor-args!))

(define-record-discloser :record-type
  (lambda (rtype)
    (list 'record-type (record-type-name rtype))))

;; Fields of record types.

(define-record-type :record-field
  (make-record-field record-type name type)
  record-field?
  (record-type  record-field-record-type)
  (name                 record-field-name)
  (type                 record-field-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.)

(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 (lookup-record-type id)
  (table-ref *record-type-table* id))

(define (all-record-types)
  (table->entry-list *record-type-table*))

;; 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 (really-make-record-type 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)
                                       (make-record-field
                                          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.

;; TODO: port expand-define-record-type to syntax-case

#|
(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))))))
|#

;; primitives
;;  (make-record 'type . args)
;;  (record-ref thing 'type 'field)
;;  (record-set! thing value 'type 'field)
;;
;; C record creator
;;  global list of these things