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