Update of /project/cparse/cvsroot/cparse
In directory common-lisp.net:/tmp/cvs-serv8040
Modified Files:
ctype.lisp cparse.system cparse.lisp ChangeLog
Added Files:
uffi-alien.lisp
Removed Files:
system.lisp
Log Message:
* uffi-alien.lisp: New file.
* system.lisp: Removed.
* ctype.lisp (print-object): moved PCL guard into lambda.
(print-object): Added allegro guard.
(defnumtype): Added escapes to documentation string.
(defnumtype): Case-robustified 'const-name' initial value.
(byte): New defnumtype.
(unsigned-byte): New defnumtype.
(short): Moved upwards
(unsigned-short): Moved upwards.
(unsignedp, min-val, c!-internal): Added ignore declaration.
(type-width): Added fallback method.
(def-c-op): Case-robustified 'internal-op' initial value.
* cparse.system: (*cparse-backend*): New variable.
(toplevel): Added require of :uffi when this is backend.
(toplevel): Guarded hash string test with CMU.
(toplevel): Added ASDF to-be-done guard.
(toplevel): Reorganised MK based defsystem.
(toplevel): Added Allegro defsystem.
* cparse.lisp (*cparse-debug*): Added documentation.
(cparse-object): Wrapped in 'eval-when',
(print-object): Moved PCL guard into lambda and added allegro guard.
(defc): Intern initargs in keyword package.
(defc): Wrapped generated class in 'eval-when'.
(+c-keywords+): Added "__extension__".
(tok): Outcommented :number case in return value.
(frob-prim-type): Case-robustified 'cparse-type' value.
(frob-prim-type): Added 'long-long' and 'unsigned-long-long'.
(array-type): Added 'int-const'.
(cparse-stream): Added escapes in documentation.
(cparse-stmt): Added consumption of '__extension__' keywords.
(parse-decl-type): Added debug-ouput.
(parse-declarator): Outcommented second version of this function.
(parse-sizeof): Added :value keyword.
(*a-pointer*): New parameter.
Date: Wed Nov 24 21:23:58 2004
Author: clynbech
Index: cparse/ctype.lisp
diff -u cparse/ctype.lisp:1.1.1.1 cparse/ctype.lisp:1.2
--- cparse/ctype.lisp:1.1.1.1 Tue Mar 19 19:02:57 2002
+++ cparse/ctype.lisp Wed Nov 24 21:23:58 2004
@@ -34,14 +34,17 @@
(defclass c-super ()
())
-#+PCL
+
(defmethod print-object ((obj c-super) stream)
(let ((slots (mapcan #'(lambda (slot-def)
- (let ((name (pcl:slot-definition-name slot-def)))
+ (let ((name
+ #+PCL (pcl:slot-definition-name slot-def)
+ #+allegro (mop:slot-definition-name slot-def)))
(if (slot-boundp obj name)
(list name (slot-value obj name))
nil)))
- (pcl:class-slots (class-of obj)))))
+ #+PCL (pcl:class-slots (class-of obj))
+ #+allegro (mop:class-slots (class-of obj)))))
(print-unreadable-object (obj stream :type t)
(format stream "~<~@{~W ~@_~W~^ ~_~}~:>" slots))))
@@ -53,9 +56,10 @@
(defmacro defnumtype (cname super &body body)
"Define class CNAME with superclasses SUPER and CNAME-CONST with superclasses
-(,@SUPER c-const)"
+\(,@SUPER c-const\)"
(let ((const-name (intern (concatenate 'string
- (symbol-name cname) "-CONST"))))
+ (symbol-name cname)
+ (symbol-name '-const)))))
`(progn
(defclass ,cname ,super ,@body)
(defclass ,const-name (,cname c-const) ,@body))))
@@ -66,6 +70,18 @@
(defclass cinteger-super ()
())
+(defnumtype byte (cinteger-super)
+ ())
+
+(defnumtype unsigned-byte (unsigned byte)
+ ())
+
+(defnumtype short (cinteger-super)
+ ())
+
+(defnumtype unsigned-short (unsigned short)
+ ())
+
(defnumtype int (cinteger-super)
())
@@ -84,12 +100,6 @@
(defnumtype unsigned-long-long (unsigned long-long)
())
-(defnumtype short (cinteger-super)
- ())
-
-(defnumtype unsigned-short (unsigned short)
- ())
-
(defclass cfloat-super ()
())
@@ -114,9 +124,11 @@
(defgeneric unsignedp (comp-imp type))
(defmethod unsignedp (comp-imp (type t))
+ (declare (ignore comp-imp))
nil)
(defmethod unsignedp (comp-imp (type unsigned))
+ (declare (ignore comp-imp))
t)
(defgeneric max-val (comp-imp type))
@@ -131,6 +143,7 @@
(1- (expt 2 (type-width comp-imp type))))
(defmethod min-val (comp-imp (type unsigned))
+ (declare (ignore comp-imp))
0)
;;; Class representing C compiler implementation characteristics.
@@ -141,6 +154,11 @@
(defgeneric type-width (comp-imp type))
+;;; fallback - this is bad but shouldn't halt generation
+(defmethod type-width (comp-imp type)
+ (warn "Type ~A is too complex for `type-width' - substituting 0!" type)
+ 0)
+
(defmethod type-width ((comp-imp compiler-impl) (type char))
8)
@@ -325,8 +343,9 @@
(type-width cimpl op1)))))
(defmacro def-c-op (c-func float-func int-func)
- (let ((internal-op (intern (concatenate 'simple-string (string c-func)
- "-INTERNAL")
+ (let ((internal-op (intern (concatenate 'simple-string
+ (string c-func)
+ (symbol-name '-internal))
:cparse)))
`(progn
(defun ,c-func (cimpl op1 op2)
@@ -416,6 +435,7 @@
(defgeneric c!-internal (cimpl op))
(defmethod c!-internal (cimpl (op c-const))
+ (declare (ignore cimpl))
(make-instance 'int-const
:value (if (= (value op) 0)
1
Index: cparse/cparse.system
diff -u cparse/cparse.system:1.1.1.1 cparse/cparse.system:1.2
--- cparse/cparse.system:1.1.1.1 Fri Aug 17 20:13:30 2001
+++ cparse/cparse.system Wed Nov 24 21:23:58 2004
@@ -1,8 +1,8 @@
-;;; -*- Lisp -*-
-;;;
-;;; Copyright (c) 2001 Timothy Moore
+;;; Copyright (c) 2001 Timothy Moore -*- lisp -*-
;;; All rights reserved.
;;;
+;;; Modified 2004 by Christian Lynbech
+;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
@@ -29,18 +29,14 @@
;;;
;;; CPARSE - library for parsing C header files.
-(mk:defsystem cparse
- :source-extension "lisp"
- :components
- ((:file "cparse-package")
- (:file "ctype" :depends-on ("cparse-package"))
- (:file "cparse" :depends-on ("cparse-package"))
- #+CMU (:file "cmu-alien-package")
- #+CMU (:file "cmu-alien" :depends-on ("cparse-package"
- "cmu-alien-package"
- "cparse"))))
+;; Choose one of the supported backends
+(defvar *cparse-backend* (nth 0 '("uffi-alien" "cmu-alien" "acl-alien")))
-;;; CMUCL 18c and earlier didn't hash strings with fill pointers correctly.
+(when (string= *cparse-backend* "uffi-alien")
+ '(require :uffi))
+
+#+CMU
+;;; CMUCL 18c and earlier doesn't hash strings with fill pointers correctly.
(let ((string-with-fill (make-array 32
:element-type 'base-char
:adjustable t
@@ -48,3 +44,26 @@
(setf (subseq string-with-fill 0) "typedef")
(unless (= (sxhash string-with-fill) (sxhash "typedef"))
(pushnew :hash-fill-bug *features*)))
+
+
+;;; We will define a system for all available defsystem systems, even
+;;; if that means duplicated info but this allows the user to work
+;;; with whatever kind of system his is most comfortable with.
+
+#+ASDF
+'(to-be-done asdf:defsystem cparse)
+
+#+MK-DEFSYSTEM
+(mk:defsystem cparse
+ :source-extension "lisp"
+ :components
+ ((:file "package")
+ (:file "ctype" :depends-on ("package"))
+ (:file "cparse" :depends-on ("package"))
+ (:file #.*cparse-backend* :depends-on ("package" "cparse"))))
+
+#+ALLEGRO
+(defsystem :cparse (:default-file-type "lisp")
+ (:serial "package"
+ (:parallel "ctype" "cparse")
+ #.*cparse-backend*))
Index: cparse/cparse.lisp
diff -u cparse/cparse.lisp:1.1.1.1 cparse/cparse.lisp:1.2
--- cparse/cparse.lisp:1.1.1.1 Tue Mar 19 19:06:38 2002
+++ cparse/cparse.lisp Wed Nov 24 21:23:58 2004
@@ -35,7 +35,9 @@
(defvar *compiler-implementation* nil)
-(defvar *cparse-debug* nil)
+(defvar *cparse-debug* nil
+ "Turn on debugging output.
+If not nil and not t turn on even more debugging output.")
(defclass lookahead-stream ()
((stream :accessor stream :initarg :stream)
@@ -233,20 +235,23 @@
;;; A superclass for all our types. We can hang our own print-object method
;;; off it and stuff.
-(defclass cparse-object ()
- ())
+(eval-when (load compile eval)
+ (defclass cparse-object ()
+ ()))
;;; Obviously there are ways to do this in other CLOSes and MOPs, but I
;;; don't know what they are.
-#+PCL
(defmethod print-object ((obj cparse-object) stream)
(let ((slots (mapcan #'(lambda (slot-def)
- (let ((name (pcl:slot-definition-name slot-def)))
+ (let ((name
+ #+PCL (pcl:slot-definition-name slot-def)
+ #+allegro (mop:slot-definition-name slot-def)))
(if (slot-boundp obj name)
(list name (slot-value obj name))
nil)))
- (pcl:class-slots (class-of obj)))))
+ #+PCL (pcl:class-slots (class-of obj))
+ #+allegro (mop:class-slots (class-of obj)))))
(print-unreadable-object (obj stream :type t)
(format stream "~<~@{~W ~@_~W~^ ~_~}~:>" slots))))
@@ -263,12 +268,13 @@
(error "Invalid slot ~S" slot)))
`(,name :accessor ,name
:initarg ,(intern (string name)
- "KEYWORD")
+ :keyword)
,@args)))
slots)))
- `(defclass ,class-name ,supers
- ,new-slots
- ,@class-options)))
+ `(eval-when (load compile eval)
+ (defclass ,class-name ,supers
+ ,new-slots
+ ,@class-options))))
;;; Classes for constant numbers
@@ -474,7 +480,7 @@
(let ((keywords '("float" "double" "typedef" "extern" "void"
"char" "int" "long" "const" "volatile" "signed"
"unsigned" "short" "struct" "union" "enum"
- "__attribute__" "__mode__" ; gcc extension
+ "__attribute__" "__mode__" "__extension__" ; gcc extension
"sizeof")))
(loop for keyword in keywords
do (setf (gethash keyword +c-keywords+) (intern keyword))))
@@ -517,9 +523,10 @@
finally (return (progn
(unreadc c lstream)
(case state
+ #+nil ;unreachable anyway according to CMUCL
((:number)
(cparse-error
- "How did we get in :number state?"))
+ "How did we get in :number state?"))
((:id)
(intern-token tok))
(t (cparse-error
@@ -544,8 +551,9 @@
new)
(macrolet ((frob-prim-type (type)
- (let ((cparse-type (intern (concatenate 'string "CPARSE-"
- (symbol-name type)))))
+ (let ((cparse-type (intern (concatenate 'string
+ (symbol-name 'cparse-)
+ (symbol-name type)))))
`(defc ,cparse-type (,type c-type)
()))))
(frob-prim-type void)
@@ -558,6 +566,8 @@
(frob-prim-type unsigned-int)
(frob-prim-type long)
(frob-prim-type unsigned-long)
+ (frob-prim-type long-long)
+ (frob-prim-type unsigned-long-long)
(frob-prim-type cfloat)
(frob-prim-type double))
@@ -569,7 +579,7 @@
(defc array-type (c-type)
((of :type c-type)
- (len :type (or fixnum null))))
+ (len :type (or int-const fixnum null))))
(defmethod %copy-type :after ((type array-type) new)
(setf (of new) (of type)
@@ -678,7 +688,8 @@
Default is an object of type 'impl-32bit.
:scope - A scope object, possibly the result of an earlier run of
cparse-stream.
-:stmt-fun - that is called for every statement with (parse-tree scope lstream)."
+:stmt-fun - that is called for every statement with
+\(parse-tree scope lstream\)."
(let* ((lstream (make-instance 'lookahead-stream
:stream stream
:file-name file-name))
@@ -700,6 +711,8 @@
(file-name lstream) (line-number lstream))))))
(defun cparse-stmt (lstream)
+ (when (member (look lstream) '(|__extension__|))
+ (consume lstream))
(when (eq (look lstream) '|typedef|)
(consume lstream)
(return-from cparse-stmt
@@ -815,24 +828,27 @@
type)))
(loop
for token = (look lstream) then (consume lstream)
- do (cond ((member token +decl-keywords+ :test #'eq)
- (push token keywords))
- ;; use value of setq
- ((setq maybe-typedef (lookup 'objects token))
- (setq typedef-type (defined-type maybe-typedef)))
- ((member token prim-qualifiers :test #'eq)
- (pushnew token qualifiers))
- ((or (eq token '|struct|) (eq token '|union|))
- (return-from parse-decl-type
- (do-qualifiers (parse-struct-union lstream))))
- ((eq token '|enum|)
- (return-from parse-decl-type
- (do-qualifiers (parse-enum lstream))))
- (t (loop-finish))))
+ do (when (and *cparse-debug* (not (eq *cparse-debug* t)))
+ (format *error-output* "Next token: ~S~%" token))
+ (cond
+ ((member token +decl-keywords+ :test #'eq)
+ (push token keywords))
+ ;; use value of setq
+ ((setq maybe-typedef (lookup 'objects token))
+ (setq typedef-type (defined-type maybe-typedef)))
+ ((member token prim-qualifiers :test #'eq)
+ (pushnew token qualifiers))
+ ((or (eq token '|struct|) (eq token '|union|))
+ (return-from parse-decl-type
+ (do-qualifiers (parse-struct-union lstream))))
+ ((eq token '|enum|)
+ (return-from parse-decl-type
+ (do-qualifiers (parse-enum lstream))))
+ (t (loop-finish))))
(if typedef-type
(do-qualifiers typedef-type)
(make-prim-type qualifiers keywords)))))
-
+#+nil ;why are there two versions of this function --tedchly/20040401
(defun parse-declarator (lstream decl-type)
(let (new-type
id
@@ -1311,7 +1327,7 @@
(push-back initial lstream)
(parse-unary-expression lstream))))
(t (parse-unary-expression lstream)))))
- (make-instance 'int-const (sizeof sized-type))))
+ (make-instance 'int-const :value (sizeof sized-type))))
(defgeneric sizeof (type))
@@ -1330,8 +1346,12 @@
(defmethod alignof ((type compound-type))
(alignment type))
+(defparameter *a-pointer* (make-instance 'pointer-type))
+
(defmethod sizeof ((type array-type))
- (* (sizeof (of type)) (value (len type))))
+ (if (len type)
+ (* (sizeof (of type)) (value (len type)))
+ (sizeof *a-pointer*)))
(defmethod alignof ((type array-type))
(alignof (of type)))
Index: cparse/ChangeLog
diff -u cparse/ChangeLog:1.3 cparse/ChangeLog:1.4
--- cparse/ChangeLog:1.3 Sat May 15 00:06:24 2004
+++ cparse/ChangeLog Wed Nov 24 21:23:58 2004
@@ -1,5 +1,50 @@
+2004-11-24 Christian Lynbech <christian.lynbech(a)ericsson.com>
+
+ * uffi-alien.lisp: New file.
+
+ * system.lisp: Removed.
+
+ * ctype.lisp (print-object): moved PCL guard into lambda.
+ (print-object): Added allegro guard.
+ (defnumtype): Added escapes to documentation string.
+ (defnumtype): Case-robustified 'const-name' initial value.
+ (byte): New defnumtype.
+ (unsigned-byte): New defnumtype.
+ (short): Moved upwards
+ (unsigned-short): Moved upwards.
+ (unsignedp, min-val, c!-internal): Added ignore declaration.
+ (type-width): Added fallback method.
+ (def-c-op): Case-robustified 'internal-op' initial value.
+
+ * cparse.system: (*cparse-backend*): New variable.
+ (toplevel): Added require of :uffi when this is backend.
+ (toplevel): Guarded hash string test with CMU.
+ (toplevel): Added ASDF to-be-done guard.
+ (toplevel): Reorganised MK based defsystem.
+ (toplevel): Added Allegro defsystem.
+
+ * cparse.lisp (*cparse-debug*): Added documentation.
+ (cparse-object): Wrapped in 'eval-when',
+ (print-object): Moved PCL guard into lambda and added allegro guard.
+ (defc): Intern initargs in keyword package.
+ (defc): Wrapped generated class in 'eval-when'.
+ (+c-keywords+): Added "__extension__".
+ (tok): Outcommented :number case in return value.
+ (frob-prim-type): Case-robustified 'cparse-type' value.
+ (frob-prim-type): Added 'long-long' and 'unsigned-long-long'.
+ (array-type): Added 'int-const'.
+ (cparse-stream): Added escapes in documentation.
+ (cparse-stmt): Added consumption of '__extension__' keywords.
+ (parse-decl-type): Added debug-ouput.
+ (parse-declarator): Outcommented second version of this function.
+ (parse-sizeof): Added :value keyword.
+ (*a-pointer*): New parameter.
+
2004-05-15 Christian Lynbech <clynbech(a)common-lisp.net>
+ * cparse-package.lisp: File removed.
+ * system.lisp: New File.
+ * package.lisp: New file.
* acl-alien.lisp: New file.
2004-05-14 Christian Lynbech <clynbech(a)common-lisp.net>
