src/method-{proto,impl}.lisp: Introduce `effective-method-live-p' protocol.
[sod] / src / c-types-parse.lisp
index b398ca9..6a622b7 100644 (file)
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -70,7 +70,7 @@
   ;; accessor functions later.
   ((label :type keyword :initarg :label :reader ds-label)
    (name :type string :initarg :name :reader ds-name)
   ;; accessor functions later.
   ((label :type keyword :initarg :label :reader ds-label)
    (name :type string :initarg :name :reader ds-name)
-   (kind :type (member type sign size qualifier)
+   (kind :type (member type complexity sign size qualifier)
         :initarg :kind :reader ds-kind)
    (taggedp :type boolean :initarg :taggedp
            :initform nil :reader ds-taggedp))
         :initarg :kind :reader ds-kind)
    (taggedp :type boolean :initarg :taggedp
            :initform nil :reader ds-taggedp))
 
 (defparameter *declspec-map*
   (let ((map (make-hash-table :test #'equal)))
 
 (defparameter *declspec-map*
   (let ((map (make-hash-table :test #'equal)))
-    (dolist (item '((type :void :char :int :float :double)
+    (dolist (item '((type :void :char :int :float :double
+                         (:bool :name "_Bool"))
+                   (complexity (:complex :name "_Complex")
+                               (:imaginary :name "_Imaginary"))
                    ((type :taggedp t) :enum :struct :union)
                    (size :short :long (:long-long :name "long long"))
                    (sign :signed :unsigned)
                    ((type :taggedp t) :enum :struct :union)
                    (size :short :long (:long-long :name "long long"))
                    (sign :signed :unsigned)
                                     :taggedp taggedp)))
              (setf (gethash name map) ds
                    (gethash label map) ds))))))
                                     :taggedp taggedp)))
              (setf (gethash name map) ds
                    (gethash label map) ds))))))
+    (dolist (label '(:complex :imaginary :bool))
+      (setf (gethash (string-downcase label) map) (gethash label map)))
     map)
   "Maps symbolic labels and textual names to `declspec' instances.")
 
     map)
   "Maps symbolic labels and textual names to `declspec' instances.")
 
   ;; This could have been done with `defstruct' just as well, but a
   ;; `defclass' can be tweaked interactively, which is a win at the moment.
   ((type :initform nil :initarg :type :reader ds-type)
   ;; This could have been done with `defstruct' just as well, but a
   ;; `defclass' can be tweaked interactively, which is a win at the moment.
   ((type :initform nil :initarg :type :reader ds-type)
+   (complexity :initform nil :initarg :complexity :reader ds-complexity)
    (sign :initform nil :initarg :sign :reader ds-sign)
    (size :initform nil :initarg :size :reader ds-size)
    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
    (sign :initform nil :initarg :sign :reader ds-sign)
    (size :initform nil :initarg :size :reader ds-size)
    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
 (defmethod ds-kind ((ty c-type)) 'type)
 
 (defparameter *good-declspecs*
 (defmethod ds-kind ((ty c-type)) 'type)
 
 (defparameter *good-declspecs*
-  '(((:int) (:signed :unsigned) (:short :long :long-long))
-    ((:char) (:signed :unsigned) ())
-    ((:double) () (:long))
-    (t () ()))
+  '(((:int) (:signed :unsigned) (:short :long :long-long) ())
+    ((:char) (:signed :unsigned) () ())
+    ((:double) () (:long) (:complex :imaginary))
+    (t () () ()))
   "List of good collections of declaration specifiers.
 
   "List of good collections of declaration specifiers.
 
-   Each item is a list of the form (TYPES SIGNS SIZES).  Each of TYPES, SIGNS
-   and SIZES is either a list of acceptable specifiers of the appropriate
-   kind, or T, which matches any specifier.")
+   Each item is a list of the form (TYPES SIGNS SIZES COMPLEXITIES).  Each of
+   TYPES, SIGNS, SIZES, and COMPLEXITIES, is either a list of acceptable
+   specifiers of the appropriate kind, or T, which matches any specifier.")
 
 (defun good-declspecs-p (specs)
   "Are SPECS a good collection of declaration specifiers?"
 
 (defun good-declspecs-p (specs)
   "Are SPECS a good collection of declaration specifiers?"
-  (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
+  (let ((speclist (list (ds-type specs)
+                       (ds-sign specs)
+                       (ds-size specs)
+                       (ds-complexity specs))))
     (some (lambda (it)
            (every (lambda (spec pat)
                     (or (eq pat t) (null spec)
     (some (lambda (it)
            (every (lambda (spec pat)
                     (or (eq pat t) (null spec)
   (let ((type (ds-type specs))
        (size (ds-size specs))
        (sign (ds-sign specs))
   (let ((type (ds-type specs))
        (size (ds-size specs))
        (sign (ds-sign specs))
+       (cplx (ds-complexity specs))
        (quals (mapcar #'ds-label (ds-qualifiers specs))))
     (cond ((typep type 'c-type)
           (qualify-c-type type quals))
        (quals (mapcar #'ds-label (ds-qualifiers specs))))
     (cond ((typep type 'c-type)
           (qualify-c-type type quals))
-         ((or type size sign)
+         ((or type size sign cplx)
           (when (and sign (eq (ds-label sign) :signed)
                      (eq (ds-label type) :int))
             (setf sign nil))
           (when (and sign (eq (ds-label sign) :signed)
                      (eq (ds-label type) :int))
             (setf sign nil))
           (make-simple-type (format nil "~{~@[~A~^ ~]~}"
                                     (mapcar #'ds-name
                                             (remove nil
           (make-simple-type (format nil "~{~@[~A~^ ~]~}"
                                     (mapcar #'ds-name
                                             (remove nil
-                                                    (list sign size type))))
+                                                    (list sign cplx
+                                                          size type))))
                             quals))
          (t
           nil))))
                             quals))
          (t
           nil))))
   ;; Turns out to be easier to do this by hand.
   (let ((ds (and (eq (token-type scanner) :id)
                 (let ((kw (token-value scanner)))
   ;; Turns out to be easier to do this by hand.
   (let ((ds (and (eq (token-type scanner) :id)
                 (let ((kw (token-value scanner)))
-                  (or (gethash kw *module-type-map*)
+                  (or (and (boundp '*module-type-map*)
+                           (gethash kw *module-type-map*))
                       (gethash kw *declspec-map*))))))
     (cond ((or (not ds) (and predicate (not (funcall predicate ds))))
           (values (list indicator) nil nil))
                       (gethash kw *declspec-map*))))))
     (cond ((or (not ds) (and predicate (not (funcall predicate ds))))
           (values (list indicator) nil nil))
 ;;; `parse-declarator' will be of this form.
 
 (export 'parse-declarator)
 ;;; `parse-declarator' will be of this form.
 
 (export 'parse-declarator)
-(defun parse-declarator (scanner base-type &key kernel abstractp)
+(defun parse-declarator (scanner base-type &key kernel abstractp keywordp)
   "Parse a C declarator, returning a pair (C-TYPE . NAME).
 
    The SCANNER is a token scanner to read from.  The BASE-TYPE is the type
   "Parse a C declarator, returning a pair (C-TYPE . NAME).
 
    The SCANNER is a token scanner to read from.  The BASE-TYPE is the type
    defaults to matching a simple identifier `:id'.  This might, e.g., be
    (? :id) to parse an `abstract declarator' which has optional names.
 
    defaults to matching a simple identifier `:id'.  This might, e.g., be
    (? :id) to parse an `abstract declarator' which has optional names.
 
+   If KEYWORDP is true, then a keyword argument list is permitted in
+   function declarations.
+
    There's an annoying ambiguity in the syntax, if an empty KERNEL is
    permitted.  In this case, you must ensure that ABSTRACTP is true so that
    the appropriate heuristic can be applied.  As a convenience, if ABSTRACTP
    is true then `(? :id)' is used as the default KERNEL."
    There's an annoying ambiguity in the syntax, if an empty KERNEL is
    permitted.  In this case, you must ensure that ABSTRACTP is true so that
    the appropriate heuristic can be applied.  As a convenience, if ABSTRACTP
    is true then `(? :id)' is used as the default KERNEL."
+
+  ;; This is a bit confusing.  This is a strangely-shaped operator grammer,
+  ;; which wouldn't be so bad, but the `values' being operated on are pairs
+  ;; of the form (FUNC . NAME).  The NAME is whatever the KERNEL parser
+  ;; produces as its result, and will be passed out unchanged.  The FUNC is a
+  ;; type-constructor function which will be eventually be applied to the
+  ;; input BASE-TYPE, but we can't calculate the actual result as we go along
+  ;; because of the rather annoying inside-out nature of the declarator
+  ;; syntax.
+
   (with-parser-context (token-scanner-context :scanner scanner)
     (let ((kernel-parser (cond (kernel kernel)
                               (abstractp (parser () (? :id)))
   (with-parser-context (token-scanner-context :scanner scanner)
     (let ((kernel-parser (cond (kernel kernel)
                               (abstractp (parser () (? :id)))
                                                         'qualifier)))))))
                     (mapcar #'ds-label quals))))
 
                                                         'qualifier)))))))
                     (mapcar #'ds-label quals))))
 
+              (disallow-keyword-functions (type)
+                (when (typep type 'c-keyword-function-type)
+                  (error "Functions with keyword arguments are only ~
+                          allowed at top-level.")))
+
               (star ()
                 ;; Prefix: `*' qualifiers
 
                 (parse (seq (#\* (quals (qualifiers)))
                          (preop "*" (state 9)
                            (cons (lambda (type)
               (star ()
                 ;; Prefix: `*' qualifiers
 
                 (parse (seq (#\* (quals (qualifiers)))
                          (preop "*" (state 9)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                             (make-pointer-type type quals)))
                                  (cdr state))))))
                                    (funcall (car state)
                                             (make-pointer-type type quals)))
                                  (cdr state))))))
                 (parse (seq ((name (funcall kernel-parser)))
                          (cons #'identity name))))
 
                 (parse (seq ((name (funcall kernel-parser)))
                          (cons #'identity name))))
 
+              (arg-decl (abstractp)
+                (parse (seq ((base-type (parse-c-type scanner))
+                             (dtor (parse-declarator scanner base-type
+                                                     :abstractp abstractp)))
+                         dtor)))
+
+              (argument ()
+                ;; argument ::= type abstract-declspec
+
+                (parse (seq ((dtor (arg-decl t)))
+                         (make-argument (cdr dtor) (car dtor)))))
+
+              (kw-argument ()
+                ;; kw-argument ::= type declspec [= c-fragment]
+
+                (parse (seq ((dtor (arg-decl nil))
+                             (dflt (? (when (eq (token-type scanner) #\=)
+                                        (parse-delimited-fragment
+                                         scanner #\= '(#\, #\))
+                                         :keep-end t)))))
+                         (make-argument (cdr dtor) (car dtor) dflt))))
+
               (argument-list ()
               (argument-list ()
-                ;; [argument [`,' argument]* [`,' `...']] | `...'
+                ;; argument-list ::=
+                ;;     [argument [`,' argument]* [`,' argument-tail]]
+                ;;   | argument-tail
+                ;;
+                ;; argument-tail ::= `...' | keyword-tail
+                ;;
+                ;; keyword-tail ::= `?' [kw-argument [`,' kw-argument]*]
+                ;;
+                ;; kw-argument ::= argument [= c-fragment]
                 ;;
                 ;; The possibility of a trailing `,' `...' means that we
                 ;; can't use the standard `list' parser.  Note that, unlike
                 ;; `real' C, we allow an ellipsis even if there are no
                 ;; explicit arguments.
 
                 ;;
                 ;; The possibility of a trailing `,' `...' means that we
                 ;; can't use the standard `list' parser.  Note that, unlike
                 ;; `real' C, we allow an ellipsis even if there are no
                 ;; explicit arguments.
 
-                (let ((args nil))
+                (let ((args nil)
+                      (keys nil)
+                      (keysp nil))
                   (loop
                     (when (eq (token-type scanner) :ellipsis)
                       (push :ellipsis args)
                       (scanner-step scanner)
                       (return))
                   (loop
                     (when (eq (token-type scanner) :ellipsis)
                       (push :ellipsis args)
                       (scanner-step scanner)
                       (return))
+                    (when (and keywordp (eq (token-type scanner) #\?))
+                      (setf keysp t)
+                      (scanner-step scanner)
+                      (multiple-value-bind (arg winp consumedp)
+                          (parse (list (:min 0) (kw-argument) #\,))
+                        (declare (ignore consumedp))
+                        (unless winp
+                          (return-from argument-list (values arg nil t)))
+                        (setf keys arg)
+                        (return)))
                     (multiple-value-bind (arg winp consumedp)
                     (multiple-value-bind (arg winp consumedp)
-                        (parse (seq ((base-type (parse-c-type scanner))
-                                     (dtor (parse-declarator scanner
-                                                             base-type
-                                                             :abstractp t)))
-                                 (make-argument (cdr dtor) (car dtor))))
+                        (argument)
                       (unless winp
                         (if (or consumedp args)
                             (return-from argument-list (values arg nil t))
                       (unless winp
                         (if (or consumedp args)
                             (return-from argument-list (values arg nil t))
                     (unless (eq (token-type scanner) #\,)
                       (return))
                     (scanner-step scanner))
                     (unless (eq (token-type scanner) #\,)
                       (return))
                     (scanner-step scanner))
-                  (values (nreverse args) t args)))
+                  (values (let ((rargs (nreverse args))
+                                (rkeys (nreverse keys)))
+                            (if keysp
+                                (lambda (ret)
+                                  (make-keyword-function-type
+                                   ret rargs rkeys))
+                                (lambda (ret)
+                                  (make-function-type ret rargs))))
+                          t
+                          (or args keysp))))
 
               (postfix-lparen ()
                 ;; Postfix: `(' argument-list `)'
 
 
               (postfix-lparen ()
                 ;; Postfix: `(' argument-list `)'
 
-                (parse (seq (#\( (args (argument-list)) #\))
+                (parse (seq (#\( (make (argument-list)) #\))
                          (postop "()" (state 10)
                            (cons (lambda (type)
                          (postop "()" (state 10)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                    (funcall (car state)
-                                            (make-function-type type args)))
+                                            (funcall make type)))
                                  (cdr state))))))
 
               (dimension ()
                                  (cdr state))))))
 
               (dimension ()
                 (parse (seq ((dims (list (:min 1) (dimension))))
                          (postop "[]" (state 10)
                            (cons (lambda (type)
                 (parse (seq ((dims (list (:min 1) (dimension))))
                          (postop "[]" (state 10)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                             (make-array-type type dims)))
                                  (cdr state)))))))
                                    (funcall (car state)
                                             (make-array-type type dims)))
                                  (cdr state)))))))