1 ;; Sample usage: Create lisp defstructs corresponding to C structures:
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.
11 (defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline #\tab)))
13 (defvar *eof* (code-char 255))
14 (defun delimiter(ch) (or (white-space ch)
15 (member ch '(#\, #\; #\{ #\} #\*))))
17 (let ((char (read-char st nil *eof*)))
22 #\/ (cond ((eql (peek-char nil st nil) #\*)
24 (sloop when (eql (read-char st) #\*)
25 do (cond ((eql (read-char st) #\/ )
26 (return-from next-char (next-char st))))))
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))))
34 (defun get-token (st &aux tem)
35 (sloop while (white-space (peek-char nil st nil))
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
41 when (delimiter (setq tem (next-char st)))
42 do (cond ((> (length x) 0)
43 (or (white-space tem) (unread-char tem st))
47 (cond ((eql tem *eof*) (return *eof*))
48 (t (vector-push-extend tem x)))))
49 (defvar *parse-list* nil)
50 (defvar *structs* nil)
52 (defun parse-file (fi &optional *structs*)
53 (with-open-file (st fi)
55 (sloop while (not (eql *eof* (setq tem (get-token st))))
56 collect (intern tem))))
59 (sloop while (setq tem (parse-struct))
60 do (push tem *structs*)
62 (get-sizes fi structs)
63 (with-open-file (st "gaz3.lsp")
65 (list structs (read st))
66 (delete-file "gaz3.lsp")))))))
72 (defparameter *type-alist* '((|short| . signed-short)
73 (|unsigned short| . unsigned-short)
74 (|char| . signed-char)
75 (|unsigned char| . unsigned-char)
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*)
86 ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum)
89 (cond ((car (member (car *parse-list*) *STRUCTS* :key 'cadr)))
90 (t (error "unknown struct ~a " (car *parse-list*))))
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*))
98 (defun parse-field ( &aux tem)
99 (cond ((eql (car *parse-list*) '|}|)
104 (let ((type (parse-type)))
106 (sloop until (eql (setq tem (pop *parse-list*)) '|;|)
107 append (get-field tem type)
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)
116 (intern (format nil "~a.~a" name (car w)))
119 `((,name ,(if (eq type t) nil 0) :type ,type)))))
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))))
127 (let* ((name (prog1 (pop *parse-list*)(expect '|{|))))
129 (sloop while (setq tem (parse-field))
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))
137 (defun get-sizes (file structs)
138 (with-open-file (st "gaz0" :direction :output)
141 do (format st "struct ~a SSS~a;~%" (second u) i))
142 (format st "~%main() {~%")
147 (printf st (format nil "(|~a| " (second u)))
148 (sloop for w in (cddr u)
151 (format nil "(char *)&SSS~a.~a - (char *)&SSS~a"
157 (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (./tmpx > gaz3.lsp) ; rm -f gaz0" file)))