From: hadden@src.honeywell.com (George D. Hadden)
Subject: Re: defstruct for xlisp?
Organization: Honeywell Systems & Research Center
Date: Tue, 26 Jan 1993 01:18:56 GMT

here's one.  i give it out in my class.

have fun.

-geo
---
George D. Hadden, Honeywell Systems and Research Center
      *** Where "Research" is our middle name! ***
3660 Technology Drive, Minneapolis, MN 55418 -- (612)951-7769
hadden@src.honeywell.com -or- hadden@umn-cs.cs.umn.edu

****************************************************************

;;; -*- Package: USER; Mode: LISP; Base: 10; Syntax: Common-Lisp; -*-
;;; public domain version of defstruct

(in-package "USER")
;;; 
;;; NOTE:  there is nothing fancy here:  defaults work; 
;;;        keywords don't, including ":include", and keyword
;;;        initialization.
;;; also, 
;;;   (defstruct foo a (b 3) c)
;;;   (setq xxx (make-foo))
;;;   (setf (foo-a xxx) 3)  ; this will not work, but
;;;   (set-foo-a xxx 3)     ; will
;;; 
;;; THIS CODE IS NOT GUARANTEED!!!

(defmacro my-defstruct (name &rest field-list)
  `(progn
      ;; first do the make function
      (defun ,(intern (strcat "MAKE-" (symbol-name name))) ()
         (let ((new-instance (gensym)))
            ;; add the type info
            (putprop new-instance ',name 'structure-type)
            ;; then do each field
            ,@(do ((fields field-list (cdr fields))
                   (result (list 'dummy))) ; don't use backquote here!
                  ((null fields) (cdr result))
                (nconc result `(,(if (listp (car fields))
                                     `(putprop
                                         new-instance
                                         ,(cadar fields)
                                         ',(caar fields))
                                     `(putprop
                                         new-instance
                                         nil
                                         ',(car fields))))))
            new-instance))
      ;; do the type predicate
      (defun ,(intern (strcat (symbol-name name) "-P")) (instance)
        (eq (get instance 'structure-type) ',name))
      ;; now do accessors and setters for each field
      ,@(do* ((fields field-list (cdr fields))
              (field-name nil)
              (result (list 'dummy)))
             ((null fields) (cdr result)) ; get rid of dummy
          (setq field-name (if (listp (car fields))
                               (caar fields)
                               (car fields)))
          (nconc result
                 `((defun ,(intern (strcat (symbol-name name)
                                           "-"
                                           (symbol-name field-name)))
                       (instance)
                     (get instance ',field-name))
                   (defun ,(intern (strcat "SET-"
                                           (symbol-name name)
                                           "-"
                                           (symbol-name field-name)))
                       (instance value)
                       ;; slightly non-standard set, but ok
                       (setf (get instance ',field-name) value)))))
      ',name))

;;; the following function is for common lisp
(defun strcat (&rest x)
  (let ((foo (car x))
        (x (cdr x)))
    (dolist (str x foo)
      (setq foo (concatenate 'string foo str)))))
Newsgroups: comp.lang.lisp