Return to record.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/record.l, revision 1.1

1.1     ! root        1: (setq rcs-common0-
        !             2:    "$Header: record.l,v 1.3 84/02/29 19:33:50 jkf Exp $")
        !             3: 
        !             4: ;;                                     -[Mon Feb 20 15:00:52 1984 by jkf]-
        !             5: ;; simple record package
        !             6: ;;
        !             7: 
        !             8: (eval-when (compile)
        !             9:    (or (get 'record 'version) (load 'record)))
        !            10: 
        !            11: (defvar record-pkg-indicator 'record-package-dr-record)
        !            12: 
        !            13: (declare (macros nil))
        !            14: 
        !            15: ;; internal macro
        !            16: (defmacro dr-error (message &rest args)
        !            17:    ;; print an error preceeded by 'defrecord'
        !            18:    ;; internal use only
        !            19:    `(error ',(concat "defrecord: " message) ,@args))
        !            20: 
        !            21: 
        !            22: ;(defrecord dr-record
        !            23: ;      name    ; name of record
        !            24: ;      storage ; 'list' or 'vector'
        !            25: ;      options ; subset of 'named', 'access-check'
        !            26: ;      fields  ; list of dr-field records
        !            27: ;)
        !            28: 
        !            29: (eval-when (compile eval)
        !            30:    (putprop 'dr-record
        !            31:            '(dr-record list nil ((fields 3 nil)
        !            32:                                  (options 2 nil)
        !            33:                                  (storage 1 nil)
        !            34:                                  (name 0 nil)))
        !            35:            record-pkg-indicator))
        !            36: (defmacro make-dr-record (&rest args) (record-pkg-construct 'dr-record args))
        !            37: (defmacro dr-record-storage (arg) `(nth 1 ,arg))
        !            38: (defmacro dr-record-options (arg) `(nth 2 ,arg))
        !            39: (defmacro dr-record-fields (arg) `(nth 3 ,arg))
        !            40: 
        !            41: ;(defrecord dr-field
        !            42: ;   ;; internal structure used to store info on fields
        !            43: ;   name
        !            44: ;   offset
        !            45: ;   defaultvalue)
        !            46: 
        !            47: (eval-when (compile eval)
        !            48:    (putprop 'dr-field
        !            49:            '(dr-field list nil ((defaultvalue 2 nil)
        !            50:                                 (offset 1 nil)
        !            51:                                 (name 0 nil)))
        !            52:            record-pkg-indicator))
        !            53: (defmacro make-dr-field (&rest args) (record-pkg-construct 'dr-field args))
        !            54: 
        !            55: (defmacro dr-field-name (arg) `(nth 0 ,arg))
        !            56: (defmacro dr-field-offset (arg) `(nth 1 ,arg))
        !            57: (defmacro dr-field-defaultvalue (arg) `(nth 2 ,arg))
        !            58: 
        !            59: ;; internal functions (called by macros)
        !            60: 
        !            61: (defun record-pkg-construct (recname args)
        !            62:    ;; called to expand a make- form.
        !            63:    ;; recname is the name of a record
        !            64: 
        !            65:    ; convert to an assq list, verifing field names
        !            66:    (let* ((dr-record (get recname record-pkg-indicator))
        !            67:          (fields (dr-record-fields dr-record))
        !            68:          (given))
        !            69:       (do ((xx args (cddr xx)))
        !            70:          ((null xx))
        !            71:          (if (assq (car xx) fields)
        !            72:             then (push (cons (car xx) (cadr xx)) given)
        !            73:             else (dr-error " for record " recname
        !            74:                           ", this field doesn't exist " (car xx))))
        !            75:       ;; now build a list of values.
        !            76:       ;; use the fact that the fields list is in the reverse order
        !            77:       (do ((xx fields (cdr xx))
        !            78:           (got)
        !            79:           (res))
        !            80:          ((null xx)
        !            81:           ;; now we have a list of values to compute to build this
        !            82:           ;; form.  
        !            83:           (caseq (dr-record-storage dr-record)
        !            84:              (list `(list ,@res))
        !            85:              (vector `(vector ,@res))
        !            86:              (t (error "record package is confused about storage type "))))
        !            87:          (if (setq got (assq (dr-field-name (car xx)) given))
        !            88:             then (push (cdr got) res)  ; given value
        !            89:             else (push (dr-field-defaultvalue (car xx))
        !            90:                        res)))))
        !            91: 
        !            92: 
        !            93: 
        !            94: (defun record-pkg-access (recname fieldname arg)
        !            95:    ;; return code access the given field in the given record
        !            96:    (let ((dr-record (get recname record-pkg-indicator))
        !            97:         (recnamefield)
        !            98:         (fieldinfo)
        !            99:         (options)
        !           100:         (storage))
        !           101:       (setq fieldinfo (assq fieldname (dr-record-fields dr-record)))
        !           102:       (setq options (dr-record-options dr-record))
        !           103:       (setq storage (dr-record-storage dr-record))
        !           104:       (if (null fieldinfo)
        !           105:         then (dr-error "internal error: can't find field " fieldname
        !           106:                        " in record " recname))
        !           107:       (if (memq 'access-check options)
        !           108:         then (setq recnamefield (assq '-record-field-name-
        !           109:                                       (dr-record-fields dr-record)))
        !           110:              `((lambda (defrecord-acma)
        !           111:                   (cond ((not (eq ',recname
        !           112:                                   ,(dr-accessor storage
        !           113:                                                 (dr-field-offset
        !           114:                                                    recnamefield)
        !           115:                                                 'defrecord-acma)))
        !           116:                          (record-pkg-illegal-access ',recname ',fieldname
        !           117:                                                     defrecord-acma))
        !           118:                         (t ,(dr-accessor storage
        !           119:                                          (dr-field-offset fieldinfo)
        !           120:                                          'defrecord-acma))))
        !           121:                ,arg)
        !           122:         else (dr-accessor storage (dr-field-offset fieldinfo) arg))))
        !           123: 
        !           124: 
        !           125: (defun dr-accessor (class index obj)
        !           126:    ;; determine the correct field accessor to get the index'th element
        !           127:    ;; from obj, give the storage type class (either list or vector).
        !           128:    ;;
        !           129:    (caseq class
        !           130:       (list `(nth ,index ,obj))
        !           131:       (vector `(vref ,obj ,index))
        !           132:       (t (error "record package: illegal storage class " class))))
        !           133: 
        !           134: (defun record-pkg-illegal-access (recname fieldname value)
        !           135:    (error "Unable to access field " fieldname " of record " recname
        !           136:          " because this is not an instance of that record: "
        !           137:          value))
        !           138:                    
        !           139:       
        !           140:          
        !           141:          
        !           142: (defun defrecord-name (form)
        !           143:    ;; user callable function to return the record name of
        !           144:    ;; a record
        !           145:    (if (defrecord-namedp form)
        !           146:       then (if (dtpr form) then (cadr form)
        !           147:            elseif (vectorp form)
        !           148:              then (vref form 1))
        !           149:       else (error "record-name: this record doesn't have a name " form)))
        !           150: 
        !           151: (defun defrecord-namedp (form)
        !           152:    ;; return t iff form is a named record
        !           153:    (let (name)
        !           154:       (and (or (and (dtpr form)
        !           155:                    (cdr form)
        !           156:                    (progn (setq name (cadr form)) t)
        !           157:                    (symbolp name))
        !           158:               (and (vectorp form)
        !           159:                    (>& (vsize form) 1)
        !           160:                    (progn (setq name (vref form 1)) t)
        !           161:                    (symbolp name)))
        !           162:           (get name record-pkg-indicator)
        !           163:           t)))
        !           164: 
        !           165: ;; external functions
        !           166: ;; The following functions are user callable
        !           167: 
        !           168: 
        !           169: (declare (macros t))
        !           170: 
        !           171: (defvar defrecord-default-flags nil)  ; what is assumed in the flag field
        !           172: 
        !           173: (defmacro defrecord (&rest form)
        !           174:    ;; user callable function
        !           175:    (if (null form)
        !           176:       then (error "defrecord: missing record name in " form))
        !           177: 
        !           178:    (let ((name (car form))
        !           179:         (args (cdr form))
        !           180:         (fields)
        !           181:         (nameargs)
        !           182:         (givenoptions defrecord-default-flags)
        !           183:         (savedoptions)
        !           184:         ;;options
        !           185:         (namedp)(access-checkp) (vectorp))
        !           186:       (if (dtpr name)
        !           187:         then (setq givenoptions (append givenoptions (cdr name))
        !           188:                    name (car name)))
        !           189: 
        !           190:       (if (not (symbolp name))
        !           191:         then (dr-error "non symbol record name " name))
        !           192: 
        !           193:       ;; process given options
        !           194:       (do ((xx  givenoptions (cdr xx)))
        !           195:          ((null xx))
        !           196:          (caseq (car xx)
        !           197:             (named (setq namedp t))
        !           198:             (access-check (setq access-checkp t))
        !           199:             (vector (setq vectorp t))
        !           200:             (t ; ignore
        !           201:             )))
        !           202:       ;; look for conflicting options
        !           203:       (if (and access-checkp (not namedp))
        !           204:         then (error "defrecord: Can't specify access-check without also specifying named " form))
        !           205: 
        !           206:       (if namedp then (push 'named savedoptions))
        !           207:       (if access-checkp then (push 'access-check savedoptions))
        !           208: 
        !           209:       (if namedp
        !           210:         then (let ((namefield `(-record-field-name- ',name)))
        !           211:                 (if args
        !           212:                    then (setq args (cons (car args)
        !           213:                                          (cons namefield
        !           214:                                                (cdr args))))
        !           215:                         else (setq args (list namefield)))))
        !           216: 
        !           217:       (do ((xx args (cdr xx))
        !           218:           (off 0 (1+ off)))
        !           219:          ((null xx))
        !           220:          (if (dtpr (car xx))
        !           221:             then (push (make-dr-field
        !           222:                           name (caar xx)
        !           223:                           offset off
        !           224:                           defaultvalue (cadar xx))
        !           225:                        fields)
        !           226:             else (push (make-dr-field
        !           227:                           name (car xx)
        !           228:                           offset off)
        !           229:                        fields)))
        !           230: 
        !           231:       
        !           232:       ; return a progn compile of an accessor and a collection
        !           233:       ; of accessors
        !           234:       `(progn 'compile
        !           235:              (eval-when (compile load eval)
        !           236:                         (putprop ',name ',(make-dr-record
        !           237:                                            name name
        !           238:                                            storage (if vectorp
        !           239:                                                        then 'vector
        !           240:                                                        else 'list)
        !           241:                                            options savedoptions
        !           242:                                            fields fields)
        !           243:                                  ',record-pkg-indicator))
        !           244:              (defmacro ,(concat 'make- name) (&rest args)
        !           245:                         (record-pkg-construct ',name args))
        !           246:              ,@(mapcar '(lambda (dr-field)
        !           247:                            `(defmacro ,(concat name
        !           248:                                                '-
        !           249:                                                (dr-field-name dr-field))
        !           250:                                        (arg)
        !           251:                                        (record-pkg-access
        !           252:                                           ',name
        !           253:                                           ',(dr-field-name dr-field)
        !           254:                                           arg)))
        !           255:                        fields))))
        !           256: 
        !           257: 
        !           258: (putprop 'record t 'version)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.