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>