home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #3 / NN_1993_3.iso / spool / comp / lang / lisp / 3361 < prev    next >
Encoding:
Text File  |  1993-01-25  |  3.8 KB  |  97 lines
  1. Xref: sparky comp.lang.lisp:3361 comp.lang.lisp.x:299
  2. Newsgroups: comp.lang.lisp,comp.lang.lisp.x
  3. Path: sparky!uunet!zaphod.mps.ohio-state.edu!uwm.edu!src.honeywell.com!hadden
  4. From: hadden@src.honeywell.com (George D. Hadden)
  5. Subject: Re: defstruct for xlisp?
  6. In-Reply-To: white3@ccs.northeastern.edu's message of Sat, 9 Jan 1993 20: 13:02 GMT
  7. Message-ID: <1993Jan26.011856.11800@src.honeywell.com>
  8. Sender: news@src.honeywell.com (News interface)
  9. Nntp-Posting-Host: darkstar.src.honeywell.com
  10. Organization: Honeywell Systems & Research Center
  11. References: <1993Jan9.201302.13309@random.ccs.northeastern.edu>
  12. Date: Tue, 26 Jan 1993 01:18:56 GMT
  13. Lines: 82
  14.  
  15. here's one.  i give it out in my class.
  16.  
  17. have fun.
  18.  
  19. -geo
  20. ---
  21. George D. Hadden, Honeywell Systems and Research Center
  22.       *** Where "Research" is our middle name! ***
  23. 3660 Technology Drive, Minneapolis, MN 55418 -- (612)951-7769
  24. hadden@src.honeywell.com -or- hadden@umn-cs.cs.umn.edu
  25.  
  26. ****************************************************************
  27.  
  28. ;;; -*- Package: USER; Mode: LISP; Base: 10; Syntax: Common-Lisp; -*-
  29. ;;; public domain version of defstruct
  30.  
  31. (in-package "USER")
  32. ;;; 
  33. ;;; NOTE:  there is nothing fancy here:  defaults work; 
  34. ;;;        keywords don't, including ":include", and keyword
  35. ;;;        initialization.
  36. ;;; also, 
  37. ;;;   (defstruct foo a (b 3) c)
  38. ;;;   (setq xxx (make-foo))
  39. ;;;   (setf (foo-a xxx) 3)  ; this will not work, but
  40. ;;;   (set-foo-a xxx 3)     ; will
  41. ;;; 
  42. ;;; THIS CODE IS NOT GUARANTEED!!!
  43.  
  44. (defmacro my-defstruct (name &rest field-list)
  45.   `(progn
  46.       ;; first do the make function
  47.       (defun ,(intern (strcat "MAKE-" (symbol-name name))) ()
  48.          (let ((new-instance (gensym)))
  49.             ;; add the type info
  50.             (putprop new-instance ',name 'structure-type)
  51.             ;; then do each field
  52.             ,@(do ((fields field-list (cdr fields))
  53.                    (result (list 'dummy))) ; don't use backquote here!
  54.                   ((null fields) (cdr result))
  55.                 (nconc result `(,(if (listp (car fields))
  56.                                      `(putprop
  57.                                          new-instance
  58.                                          ,(cadar fields)
  59.                                          ',(caar fields))
  60.                                      `(putprop
  61.                                          new-instance
  62.                                          nil
  63.                                          ',(car fields))))))
  64.             new-instance))
  65.       ;; do the type predicate
  66.       (defun ,(intern (strcat (symbol-name name) "-P")) (instance)
  67.         (eq (get instance 'structure-type) ',name))
  68.       ;; now do accessors and setters for each field
  69.       ,@(do* ((fields field-list (cdr fields))
  70.               (field-name nil)
  71.               (result (list 'dummy)))
  72.              ((null fields) (cdr result)) ; get rid of dummy
  73.           (setq field-name (if (listp (car fields))
  74.                                (caar fields)
  75.                                (car fields)))
  76.           (nconc result
  77.                  `((defun ,(intern (strcat (symbol-name name)
  78.                                            "-"
  79.                                            (symbol-name field-name)))
  80.                        (instance)
  81.                      (get instance ',field-name))
  82.                    (defun ,(intern (strcat "SET-"
  83.                                            (symbol-name name)
  84.                                            "-"
  85.                                            (symbol-name field-name)))
  86.                        (instance value)
  87.                        ;; slightly non-standard set, but ok
  88.                        (setf (get instance ',field-name) value)))))
  89.       ',name))
  90.  
  91. ;;; the following function is for common lisp
  92. (defun strcat (&rest x)
  93.   (let ((foo (car x))
  94.         (x (cdr x)))
  95.     (dolist (str x foo)
  96.       (setq foo (concatenate 'string foo str)))))
  97.