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@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@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@common-lisp.net