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

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