cstruct.lisp

   1 ;; Sample usage:  Create lisp defstructs corresponding to C structures:
   2 (use-package "SLOOP")
   3 ;; How to: Create a file foo.c which contains just structures
   4 ;; and possibly some externs.
   5 ;; cc -E /tmp/foo1.c  > /tmp/fo2.c
   6 ;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c
   7 ;; then (parse-file "/tmp/fo3.c")
   8 ;; will return a list of defstructs and appropriate slot offsets.
   9
  10
  11 (defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline  #\tab)))
  12
  13 (defvar *eof* (code-char 255))
  14 (defun delimiter(ch) (or (white-space ch)
  15                          (member ch '(#\, #\;  #\{ #\} #\*))))
  16 (defun next-char (st)
  17   (let ((char (read-char st nil *eof*)))
  18
  19     (case char
  20       (#\{  char)
  21       (
  22        #\/ (cond ((eql (peek-char nil st nil) #\*)
  23                   (read-char st)
  24                   (sloop when (eql (read-char st) #\*)
  25                         do (cond ((eql (read-char st) #\/ )
  26                                   (return-from next-char (next-char st))))))
  27                 (t char)))
  28       ((#\tab #\linefeed #\return #\newline )
  29        (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline  ))
  30               (return-from next-char (next-char st))))
  31        #\space)
  32       (t char))))
  33
  34 (defun get-token (st &aux tem)
  35   (sloop while (white-space (peek-char nil st nil))
  36          do (read-char st))
  37   (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} ))
  38          (return-from get-token (coerce (list (next-char st)) 'string))))
  39   (sloop with x = (make-array 10 :element-type 'character  :fill-pointer 0
  40                               :adjustable t)
  41     when  (delimiter (setq tem (next-char st)))
  42     do (cond ((> (length x) 0)
  43               (or (white-space tem) (unread-char tem st))
  44               (return x)))
  45     else
  46     do
  47     (cond ((eql tem *eof*) (return *eof*))
  48           (t    (vector-push-extend tem x)))))
  49 (defvar *parse-list* nil)
  50 (defvar *structs* nil)
  51
  52 (defun parse-file (fi &optional *structs*)
  53   (with-open-file (st fi)
  54     (let ((*parse-list*
  55       (sloop while (not (eql *eof* (setq tem (get-token st))))
  56              collect  (intern tem))))
  57       (print *parse-list*)
  58       (let ((structs
  59             (sloop while (setq tem (parse-struct))
  60                    do (push tem *structs*)
  61                    collect tem)))
  62         (get-sizes fi structs)
  63         (with-open-file (st "gaz3.lsp")
  64           (prog1
  65           (list structs (read st))
  66           (delete-file "gaz3.lsp")))))))
  67
  68
  69
  70
  71
  72 (defparameter *type-alist* '((|short| . signed-short)
  73                        (|unsigned short| . unsigned-short)
  74                        (|char| . signed-char)
  75                        (|unsigned char| . unsigned-char)
  76                        (|int| . fixnum)
  77                        (|long| . fixnum)
  78                        (|object| . t)))
  79
  80
  81 (defun parse-type( &aux top)
  82    (setq top (pop *parse-list*))
  83   (cond ((member top '(|unsigned| |signed|))
  84          (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*)
  85          (parse-type))
  86         ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum)
  87         ((eq top '|struct|)
  88          (prog1
  89              (cond ((car (member (car *parse-list*)  *STRUCTS* :key 'cadr)))
  90                (t (error "unknown struct ~a " (car *parse-list*))))
  91            (pop *parse-list*)
  92            ))
  93         ((cdr (assoc top *type-alist*)))
  94         (t (error "unknown type ~a " top))))
  95 (defun expect (x) (or (eql (car *parse-list*) x)
  96                       (error "expected ~a at beginning of ~s" x *parse-list*))
  97   (pop *parse-list*))
  98 (defun parse-field ( &aux tem)
  99   (cond ((eql (car *parse-list*) '|}|)
 100          (pop *parse-list*)
 101          (expect '|;|)
 102          nil)
 103         (t
 104         (let ((type (parse-type)))
 105
 106           (sloop until (eql (setq tem (pop *parse-list*)) '|;|)
 107                  append (get-field tem type)
 108
 109                  do (or (eq (car *parse-list*) '|;|) (expect '|,|)))))))
 110 (deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum))
 111 (defun get-field (name type)
 112   (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer))
 113         ((and (consp type) (eq (car type) 'defstruct))
 114          (sloop for w in (cddr type)
 115                 append (get-field
 116                          (intern (format nil "~a.~a" name (car w)))
 117                          (fourth w))))
 118         (t
 119          `((,name ,(if (eq type t) nil 0) :type ,type)))))
 120
 121 (defun parse-struct ()
 122   (cond ((null *parse-list*) (return-from parse-struct nil)))
 123   (cond ((not (eq (car *parse-list*) '|struct|))
 124          (sloop until (eq (pop *parse-list*) '|;|))
 125          (return-from parse-struct (parse-struct))))
 126   (expect '|struct|)
 127   (let* ((name (prog1 (pop *parse-list*)(expect '|{|))))
 128     `(defstruct ,name ,@
 129            (sloop while (setq tem (parse-field))
 130            append tem))))
 131
 132 (defun printf (st x &rest y)
 133   (format st "~%printf(\"~a\"" x)
 134   (sloop for w in y do (princ "," st) (princ y st))
 135   (princ ");" st))
 136
 137 (defun get-sizes (file structs)
 138   (with-open-file (st "gaz0" :direction :output)
 139     (sloop for i from 1
 140            for u in structs
 141            do (format st "struct ~a SSS~a;~%" (second u) i))
 142     (format st "~%main() {~%")
 143     (printf st "(")
 144     (sloop for i from 1
 145            for u in structs
 146            do
 147            (printf st (format nil "(|~a| " (second u)))
 148            (sloop for w in (cddr u)
 149                   do
 150                   (printf st " %d "
 151                           (format nil "(char *)&SSS~a.~a - (char *)&SSS~a"
 152                                   i (car w) i)))
 153            (printf st ")"))
 154     (printf st ")")
 155     (princ " ;}" st))
 156   (system
 157    (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (./tmpx > gaz3.lsp) ; rm -f  gaz0" file)))