cgit.sxemacs.org Git - riece/blob - lisp/riece-develop.el

   1 (defun riece-insert-struct-template (prefix struct)
   2   (interactive "sPrefix:
   3 sStruct: ")
   4   (let (attributes
   5         optional-attributes
   6         name
   7         pointer
   8         arglist
   9         strings
  10         (index 0))
  11     (catch 'finish
  12       (while t
  13         (setq name (read-from-minibuffer "Attribute: "))
  14         (if (equal name "")
  15             (throw 'finish nil))
  16         (setq attributes
  17               (cons (vector name
  18                             (y-or-n-p "Optional? ")
  19                             (y-or-n-p "Readable? ")
  20                             (y-or-n-p "Writable? "))
  21                     attributes))))
  22     (setq attributes (nreverse attributes)
  23           pointer (cons (vector "" nil nil nil)  attributes))
  24     (while (cdr pointer)
  25       (if (aref (car (cdr pointer)) 1)
  26           (progn
  27             (setq optional-attributes (cons (car (cdr pointer))
  28                                             optional-attributes))
  29             (setcdr pointer (nthcdr 2 pointer)))
  30         (setq pointer (cdr pointer))))
  31     (setq optional-attributes (nreverse optional-attributes)
  32           arglist (mapconcat (lambda (attribute)
  33                                (aref attribute 0))
  34                              attributes " "))
  35     (if optional-attributes
  36         (setq arglist (concat arglist " &optional "
  37                               (mapconcat (lambda (attribute)
  38                                            (aref attribute 0))
  39                                          optional-attributes " "))))
  40     (setq strings (list (format "\
  41 \(defun %smake-%s (%s)
  42   \"Make %s%s object.\"
  43   (vector %s))"
  44                                 prefix struct arglist
  45                                 prefix struct
  46                                 (mapconcat (lambda (attribute)
  47                                              (aref attribute 0))
  48                                            (append attributes
  49                                                    optional-attributes)
  50                                            " "))))
  51     (setq pointer (append attributes optional-attributes))
  52     (while pointer
  53       (if (aref (car pointer) 2)
  54           (setq strings (cons (format "\
  55 \(defun %s%s-%s (%s)
  56   \"Return %s of %s.\"
  57   (aref %s %d))"
  58                                       prefix struct (aref (car pointer) 0)
  59                                       struct
  60                                       (aref (car pointer) 0)
  61                                       (upcase struct)
  62                                       struct index)
  63                               strings)))
  64       (if (aref (car pointer) 3)
  65           (setq strings (cons (format "\
  66 \(defun %s%s-set-%s (%s %s)
  67   \"Set %s of %s to %s.\"
  68   (aset %s %d %s))"
  69                                       prefix struct (aref (car pointer) 0)
  70                                       struct (aref (car pointer) 0)
  71                                       (aref (car pointer) 0)
  72                                       (upcase struct)
  73                                       (upcase (aref (car pointer) 0))
  74                                       struct index (aref (car pointer) 0))
  75                               strings)))
  76       (setq pointer (cdr pointer)
  77             index (1+ index)))
  78     (insert (mapconcat #'identity (nreverse strings) "\n\n"))))