usr/lib/lisp/record.l

(setq rcs-common0-
   "$Header: record.l,v 1.3 84/02/29 19:33:50 jkf Exp $")

;;                                      -[Mon Feb 20 15:00:52 1984 by jkf]-
;; simple record package
;;

(eval-when (compile)
   (or (get 'record 'version) (load 'record)))

(defvar record-pkg-indicator 'record-package-dr-record)

(declare (macros nil))

;; internal macro
(defmacro dr-error (message &rest args)
   ;; print an error preceeded by 'defrecord'
   ;; internal use only
   `(error ',(concat "defrecord: " message) ,@args))


;(defrecord dr-record
;       name    ; name of record
;       storage ; 'list' or 'vector'
;       options ; subset of 'named', 'access-check'
;       fields  ; list of dr-field records
;)

(eval-when (compile eval)
   (putprop 'dr-record
            '(dr-record list nil ((fields 3 nil)
                                  (options 2 nil)
                                  (storage 1 nil)
                                  (name 0 nil)))
            record-pkg-indicator))
(defmacro make-dr-record (&rest args) (record-pkg-construct 'dr-record args))
(defmacro dr-record-storage (arg) `(nth 1 ,arg))
(defmacro dr-record-options (arg) `(nth 2 ,arg))
(defmacro dr-record-fields (arg) `(nth 3 ,arg))

;(defrecord dr-field
;   ;; internal structure used to store info on fields
;   name
;   offset
;   defaultvalue)

(eval-when (compile eval)
   (putprop 'dr-field
            '(dr-field list nil ((defaultvalue 2 nil)
                                 (offset 1 nil)
                                 (name 0 nil)))
            record-pkg-indicator))
(defmacro make-dr-field (&rest args) (record-pkg-construct 'dr-field args))

(defmacro dr-field-name (arg) `(nth 0 ,arg))
(defmacro dr-field-offset (arg) `(nth 1 ,arg))
(defmacro dr-field-defaultvalue (arg) `(nth 2 ,arg))

;; internal functions (called by macros)

(defun record-pkg-construct (recname args)
   ;; called to expand a make- form.
   ;; recname is the name of a record

   ; convert to an assq list, verifing field names
   (let* ((dr-record (get recname record-pkg-indicator))
          (fields (dr-record-fields dr-record))
          (given))
      (do ((xx args (cddr xx)))
          ((null xx))
          (if (assq (car xx) fields)
             then (push (cons (car xx) (cadr xx)) given)
             else (dr-error " for record " recname
                           ", this field doesn't exist " (car xx))))
      ;; now build a list of values.
      ;; use the fact that the fields list is in the reverse order
      (do ((xx fields (cdr xx))
           (got)
           (res))
          ((null xx)
           ;; now we have a list of values to compute to build this
           ;; form.
           (caseq (dr-record-storage dr-record)
              (list `(list ,@res))
              (vector `(vector ,@res))
              (t (error "record package is confused about storage type "))))
          (if (setq got (assq (dr-field-name (car xx)) given))
             then (push (cdr got) res)  ; given value
             else (push (dr-field-defaultvalue (car xx))
                        res)))))


(defun record-pkg-access (recname fieldname arg)
   ;; return code access the given field in the given record
   (let ((dr-record (get recname record-pkg-indicator))
         (recnamefield)
         (fieldinfo)
         (options)
         (storage))
      (setq fieldinfo (assq fieldname (dr-record-fields dr-record)))
      (setq options (dr-record-options dr-record))
      (setq storage (dr-record-storage dr-record))
      (if (null fieldinfo)
         then (dr-error "internal error: can't find field " fieldname
                        " in record " recname))
      (if (memq 'access-check options)
         then (setq recnamefield (assq '-record-field-name-
                                       (dr-record-fields dr-record)))
              `((lambda (defrecord-acma)
                   (cond ((not (eq ',recname
                                   ,(dr-accessor storage
                                                 (dr-field-offset
                                                    recnamefield)
                                                 'defrecord-acma)))
                          (record-pkg-illegal-access ',recname ',fieldname
                                                     defrecord-acma))
                         (t ,(dr-accessor storage
                                          (dr-field-offset fieldinfo)
                                          'defrecord-acma))))
                ,arg)
         else (dr-accessor storage (dr-field-offset fieldinfo) arg))))


(defun dr-accessor (class index obj)
   ;; determine the correct field accessor to get the index'th element
   ;; from obj, give the storage type class (either list or vector).
   ;;
   (caseq class
      (list `(nth ,index ,obj))
      (vector `(vref ,obj ,index))
      (t (error "record package: illegal storage class " class))))

(defun record-pkg-illegal-access (recname fieldname value)
   (error "Unable to access field " fieldname " of record " recname
          " because this is not an instance of that record: "
          value))


(defun defrecord-name (form)
   ;; user callable function to return the record name of
   ;; a record
   (if (defrecord-namedp form)
      then (if (dtpr form) then (cadr form)
            elseif (vectorp form)
              then (vref form 1))
      else (error "record-name: this record doesn't have a name " form)))

(defun defrecord-namedp (form)
   ;; return t iff form is a named record
   (let (name)
      (and (or (and (dtpr form)
                    (cdr form)
                    (progn (setq name (cadr form)) t)
                    (symbolp name))
               (and (vectorp form)
                    (>& (vsize form) 1)
                    (progn (setq name (vref form 1)) t)
                    (symbolp name)))
           (get name record-pkg-indicator)
           t)))

;; external functions
;; The following functions are user callable


(declare (macros t))

(defvar defrecord-default-flags nil)  ; what is assumed in the flag field

(defmacro defrecord (&rest form)
   ;; user callable function
   (if (null form)
      then (error "defrecord: missing record name in " form))

   (let ((name (car form))
         (args (cdr form))
         (fields)
         (nameargs)
         (givenoptions defrecord-default-flags)
         (savedoptions)
         ;;options
         (namedp)(access-checkp) (vectorp))
      (if (dtpr name)
         then (setq givenoptions (append givenoptions (cdr name))
                    name (car name)))

      (if (not (symbolp name))
         then (dr-error "non symbol record name " name))

      ;; process given options
      (do ((xx  givenoptions (cdr xx)))
          ((null xx))
          (caseq (car xx)
             (named (setq namedp t))
             (access-check (setq access-checkp t))
             (vector (setq vectorp t))
             (t ; ignore
             )))
      ;; look for conflicting options
      (if (and access-checkp (not namedp))
         then (error "defrecord: Can't specify access-check without also specifying named " form))

      (if namedp then (push 'named savedoptions))
      (if access-checkp then (push 'access-check savedoptions))

      (if namedp
         then (let ((namefield `(-record-field-name- ',name)))
                 (if args
                    then (setq args (cons (car args)
                                          (cons namefield
                                                (cdr args))))
                         else (setq args (list namefield)))))

      (do ((xx args (cdr xx))
           (off 0 (1+ off)))
          ((null xx))
          (if (dtpr (car xx))
             then (push (make-dr-field
                           name (caar xx)
                           offset off
                           defaultvalue (cadar xx))
                        fields)
             else (push (make-dr-field
                           name (car xx)
                           offset off)
                        fields)))


      ; return a progn compile of an accessor and a collection
      ; of accessors
      `(progn 'compile
              (eval-when (compile load eval)
                         (putprop ',name ',(make-dr-record
                                            name name
                                            storage (if vectorp
                                                        then 'vector
                                                        else 'list)
                                            options savedoptions
                                            fields fields)
                                  ',record-pkg-indicator))
              (defmacro ,(concat 'make- name) (&rest args)
                         (record-pkg-construct ',name args))
              ,@(mapcar '(lambda (dr-field)
                            `(defmacro ,(concat name
                                                '-
                                                (dr-field-name dr-field))
                                        (arg)
                                        (record-pkg-access
                                           ',name
                                           ',(dr-field-name dr-field)
                                           arg)))
                        fields))))


(putprop 'record t 'version)