mdw@git.distorted.org.uk Git - sod/blob - pre-reorg/cutting-room-floor.lisp

   1 ;;;--------------------------------------------------------------------------
   2 ;;; C types stuff.
   3
   4 (cl:defpackage #:c-types
   5   (:use #:common-lisp
   6         #+sbcl #:sb-mop
   7         #+(or cmu clisp) #:mop
   8         #+ecl #:clos)
   9   (:export #:c-type
  10            #:c-declarator-priority #:maybe-parenthesize
  11            #:pprint-c-type
  12            #:c-type-subtype #:compount-type-declaration
  13            #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
  14            #:simple-c-type #:c-type-name
  15            #:c-pointer-type
  16            #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
  17            #:tagged-c-type-kind
  18            #:c-array-type #:c-array-dimensions
  19            #:make-argument #:argument-name #:argument-type
  20            #:c-function-type #:c-function-arguments
  21
  22            #:define-c-type-syntax #:c-type-alias #:defctype
  23            #:print-c-type
  24            #:qualifier #:declare-qualifier
  25            #:define-simple-c-type
  26
  27            #:const #:volatile #:static #:restrict
  28            #:char #:unsigned-char #:uchar #:signed-char #:schar
  29            #:int #:signed #:signed-int #:sint
  30            #:unsigned #:unsigned-int #:uint
  31            #:short #:signed-short #:short-int #:signed-short-int #:sshort
  32            #:unsigned-short #:unsigned-short-int #:ushort
  33            #:long #:signed-long #:long-int #:signed-long-int #:slong
  34            #:unsigned-long #:unsigned-long-int #:ulong
  35            #:float #:double #:long-double
  36            #:pointer #:ptr
  37            #:[] #:vec
  38            #:fun #:func #:fn))
  39
  40
  41 ;;;--------------------------------------------------------------------------
  42 ;;; Convenient syntax for C types.
  43
  44 ;; Basic machinery.
  45
  46 ;; Qualifiers.  They have hairy syntax and need to be implemented by hand.
  47
  48 ;; Simple types.
  49
  50 ;; Pointers.
  51
  52 ;; Tagged types.
  53
  54 ;; Arrays.
  55
  56 ;; Functions.
  57
  58
  59 (progn
  60   (defconstant q-byte (byte 3 0))
  61   (defconstant q-const 1)
  62   (defconstant q-volatile 2)
  63   (defconstant q-restrict 4)
  64
  65   (defconstant z-byte (byte 3 3))
  66   (defconstant z-unspec 0)
  67   (defconstant z-short 1)
  68   (defconstant z-long 2)
  69   (defconstant z-long-long 3)
  70   (defconstant z-double 4)
  71   (defconstant z-long-double 5)
  72
  73   (defconstant s-byte (byte 2 6))
  74   (defconstant s-unspec 0)
  75   (defconstant s-signed 1)
  76   (defconstant s-unsigned 2)
  77
  78   (defconstant t-byte (byte 3 8))
  79   (defconstant t-unspec 0)
  80   (defconstant t-int 1)
  81   (defconstant t-char 2)
  82   (defconstant t-float 3)
  83   (defconstant t-user 4))
  84
  85 (defun make-type-flags (size sign type &rest quals)
  86   (let ((flags 0))
  87     (dolist (qual quals)
  88       (setf flags (logior flags qual)))
  89     (setf (ldb z-byte flags) size
  90           (ldb s-byte flags) sign
  91           (ldb t-byte flags) type)
  92     flags))
  93
  94
  95 (defun expand-c-type (spec)
  96   "Parse SPEC as a C type and return the result.
  97
  98    The SPEC can be one of the following.
  99
 100      * A C-TYPE object, which is returned immediately.
 101
 102      * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
 103        function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
 104        or some other means is invoked on the ARGUMENTS, and the result is
 105        returned.
 106
 107      * A symbol, which is treated the same way as a singleton list would be."
 108
 109   (flet ((interp (sym)
 110            (or (get sym 'c-type)
 111                (error "Unknown C type operator ~S." sym))))
 112     (etypecase spec
 113       (c-type spec)
 114       (symbol (funcall (interp spec)))
 115       (list (apply (interp (car spec)) (cdr spec))))))
 116
 117 (defmacro c-type (spec)
 118   "Evaluates to the type that EXPAND-C-TYPE would return.
 119
 120    Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
 121    later it will do something more clever."
 122   `(expand-c-type ',spec))
 123
 124 ;; S-expression machinery.  Qualifiers have hairy syntax and need to be
 125 ;; implemented by hand.
 126
 127 (defun qualifier (qual &rest args)
 128   "Parse a qualified C type.
 129
 130    The ARGS consist of a number of qualifiers and exactly one C-type
 131    S-expression.  The result is a qualified version of this type, with the
 132    given qualifiers attached."
 133   (if (null args)
 134       qual
 135       (let* ((things (mapcar #'expand-c-type args))
 136              (quals (delete-duplicates
 137                      (sort (cons qual (remove-if-not #'keywordp things))
 138                            #'string<)))
 139              (types (remove-if-not (lambda (thing) (typep thing 'c-type))
 140                                    things)))
 141         (when (or (null types)
 142                   (not (null (cdr types))))
 143           (error "Only one proper type expected in ~S." args))
 144         (qualify-type (car types) quals))))
 145 (setf (get 'qualifier 'c-type) #'qualifier)
 146
 147 (defun declare-qualifier (qual)
 148   "Defines QUAL as being a type qualifier.
 149
 150    When used as a C-type operator, it applies that qualifier to the type that
 151    is its argument."
 152   (let ((kw (intern (string qual) :keyword)))
 153     (setf (get qual 'c-type)
 154           (lambda (&rest args)
 155             (apply #'qualifier kw args)))))
 156
 157 ;; Define some initial qualifiers.
 158 (dolist (qual '(const volatile restrict))
 159   (declare-qualifier qual))
 160
 161
 162 (define-c-type-syntax simple-c-type (name)
 163   "Constructs a simple C type called NAME (a string or symbol)."
 164   (make-simple-type (c-name-case name)))
 165
 166 (defmethod print-c-type :around
 167     (stream (type qualifiable-c-type) &optional colon atsign)
 168   (if (c-type-qualifiers type)
 169       (pprint-logical-block (stream nil :prefix "(" :suffix ")")
 170         (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
 171                 (c-type-qualifiers type))
 172         (call-next-method stream type colon atsign))
 173       (call-next-method)))
 174 ;; S-expression syntax.
 175
 176
 177 (define-c-type-syntax enum (tag)
 178   "Construct an enumeration type named TAG."
 179   (make-instance 'c-enum-type :tag (c-name-case tag)))
 180 (define-c-type-syntax struct (tag)
 181   "Construct a structure type named TAG."
 182   (make-instance 'c-struct-type :tag (c-name-case tag)))
 183 (define-c-type-syntax union (tag)
 184   "Construct a union type named TAG."
 185   (make-instance 'c-union-type :tag (c-name-case tag)))
 186
 187 (defgeneric make-me-argument (message class)
 188   (:documentation
 189    "Return an ARGUMENT object for the `me' argument to MESSAGE, as
 190    specialized to CLASS."))
 191
 192 (defmethod make-me-argument
 193     ((message basic-message) (class sod-class))
 194   (make-argument "me" (make-instance 'c-pointer-type
 195                                      :subtype (sod-class-type class))))
 196
 197 ;;;--------------------------------------------------------------------------
 198 ;;; Keyword arguments and lambda lists.
 199
 200 (eval-when (:compile-toplevel :load-toplevel :execute)
 201   (defun transform-otherkeys-lambda-list (bvl)
 202     "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
 203
 204    &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
 205    (which must also be present); &ALLOW-OTHER-KEYS must not be present.
 206
 207    The behaviour is that
 208
 209      * the presence of non-listed keyword arguments is permitted, as if
 210        &ALLOW-OTHER-KEYS had been provided, and
 211
 212      * a list of the keyword arguments other than the ones explicitly listed
 213        is stored in the VAR.
 214
 215    The return value is a replacement BVL which binds the &OTHER-KEYS variable
 216    as an &AUX parameter if necessary.
 217
 218    At least for now, fancy things like destructuring lambda-lists aren't
 219    supported.  I suspect you'll get away with a specializing lambda-list."
 220
 221     (prog ((new-bvl nil)
 222            (rest-var nil)
 223            (keywords nil)
 224            (other-keys-var nil)
 225            (tail bvl))
 226
 227      find-rest
 228        ;; Scan forwards until we find &REST or &KEY.  If we find the former,
 229        ;; then remember the variable name.  If we find the latter first then
 230        ;; there can't be a &REST argument, so we should invent one.  If we
 231        ;; find neither then there's nothing to do.
 232        (when (endp tail)
 233          (go ignore))
 234        (let ((item (pop tail)))
 235          (push item new-bvl)
 236          (case item
 237            (&rest (when (endp tail)
 238                     (error "Missing &REST argument name"))
 239                   (setf rest-var (pop tail))
 240                   (push rest-var new-bvl))
 241            (&aux (go ignore))
 242            (&key (unless rest-var
 243                    (setf rest-var (gensym "REST"))
 244                    (setf new-bvl (nconc (list '&key rest-var '&rest)
 245                                         (cdr new-bvl))))
 246                  (go scan-keywords)))
 247          (go find-rest))
 248
 249      scan-keywords
 250        ;; Read keyword argument specs one-by-one.  For each one, stash it on
 251        ;; the NEW-BVL list, and also parse it to extract the keyword, which
 252        ;; we stash in KEYWORDS.  If we don't find &OTHER-KEYS then there's
 253        ;; nothing for us to do.
 254        (when (endp tail)
 255          (go ignore))
 256        (let ((item (pop tail)))
 257          (push item new-bvl)
 258          (case item
 259            ((&aux &allow-other-keys) (go ignore))
 260            (&other-keys (go fix-tail)))
 261          (let ((keyword (if (symbolp item)
 262                             (intern (symbol-name item) :keyword)
 263                             (let ((var (car item)))
 264                               (if (symbolp var)
 265                                   (intern (symbol-name var) :keyword)
 266                                   (car var))))))
 267            (push keyword keywords))
 268          (go scan-keywords))
 269
 270      fix-tail
 271        ;; We found &OTHER-KEYS.  Pick out the &OTHER-KEYS var.
 272        (pop new-bvl)
 273        (when (endp tail)
 274          (error "Missing &OTHER-KEYS argument name"))
 275        (setf other-keys-var (pop tail))
 276        (push '&allow-other-keys new-bvl)
 277
 278        ;; There should be an &AUX next.  If there isn't, assume there isn't
 279        ;; one and provide our own.  (This is safe as long as nobody else is
 280        ;; expecting to plumb in lambda keywords too.)
 281        (when (and (not (endp tail)) (eq (car tail) '&aux))
 282          (pop tail))
 283        (push '&aux new-bvl)
 284
 285        ;; Add our shiny new &AUX argument.
 286        (let ((keys-var (gensym "KEYS"))
 287              (list-var (gensym "LIST")))
 288          (push `(,other-keys-var (do ((,list-var nil)
 289                                       (,keys-var ,rest-var (cddr ,keys-var)))
 290                                      ((endp ,keys-var) (nreverse ,list-var))
 291                                    (unless (member (car ,keys-var)
 292                                                    ',keywords)
 293                                      (setf ,list-var
 294                                            (cons (cadr ,keys-var)
 295                                                  (cons (car ,keys-var)
 296                                                        ,list-var))))))
 297                new-bvl))
 298
 299        ;; Done.
 300        (return (nreconc new-bvl tail))
 301
 302      ignore
 303        ;; Nothing to do.  Return the unmolested lambda-list.
 304        (return bvl))))
 305
 306 (defmacro lambda-otherkeys (bvl &body body)
 307   "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
 308   `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
 309
 310 (defmacro defun-otherkeys (name bvl &body body)
 311   "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
 312   `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
 313
 314 (defmacro defmethod-otherkeys (name &rest stuff)
 315   "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
 316   (do ((quals nil)
 317        (stuff stuff (cdr stuff)))
 318       ((listp (car stuff))
 319        `(defmethod ,name ,@(nreverse quals)
 320             ,(transform-otherkeys-lambda-list (car stuff))
 321           ,@(cdr stuff)))
 322     (push (car stuff) quals)))
 323
 324
 325 (defparse many ((acc init update
 326                  &key (new 'it) (final acc) (min nil minp) max (commitp t))
 327                 parser &optional (sep nil sepp))
 328   "Parse a sequence of homogeneous items.
 329
 330    The behaviour is similar to `do'.  Initially an accumulator ACC is
 331    established, and bound to the value of INIT.  The PARSER is then evaluated
 332    repeatedly.  Each time it succeeds, UPDATE is evaluated with NEW (defaults
 333    to `it') bound to the result of the parse, and the value returned by
 334    UPDATE is stored back into ACC.  If the PARSER fails, then the parse ends.
 335
 336    If a SEP parser is provided, then the behaviour changes as follows.
 337    Before each attempt to parse a new item using PARSER, the parser SEP is
 338    invoked.  If SEP fails then the parse ends; if SEP succeeds, then the
 339    PARSER must also succeed or the overall parse will fail.
 340
 341    If MAX (which will be evaluated) is not nil, then it must be a number: the
 342    parse ends automatically after PARSER has succeeded MAX times.  When the
 343    parse has ended, if the PARSER succeeded fewer than MIN (which will be
 344    evaluated) times then the parse fails.  Otherwise, the FINAL form (which
 345    defaults to simply returning ACC) is evaluated and its value becomes the
 346    result of the parse.  MAX defaults to nil -- i.e., no maximum; MIN
 347    defaults to 1 if a SEP parser is given, or 0 if not.
 348
 349    Note that `many' cannot fail if MIN is zero."
 350
 351   (unless minp (setf min (if sepp 1 0)))
 352   (with-gensyms (block value win consumedp cp i up done)
 353     (once-only (init min max commitp)
 354       (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
 355         `(block ,block
 356
 357            ;; Keep track of variables.  We only need an accumulator if it's
 358            ;; not nil, and we don't need a counter if (a) there's no maximum,
 359            ;; and either (b) the minimum is zero, or (c) the minimum is one
 360            ;; and there's a separator.  In case (c), we can keep track of how
 361            ;; much has been seen using control flow.
 362            (let ((,consumedp nil)
 363                  ,@(and acc `((,acc ,init)))
 364                  ,@(and counterp `((,i 0))))
 365
 366              ;; Some handy functions.  `up' will update the accumulator.
 367              ;; `done' will return the necessary final value.
 368              (flet (,@(and acc `((,up (,new)
 369                                    (declare (ignorable ,new))
 370                                    (setf ,acc ,update))))
 371                     (,done () (return-from ,block
 372                                 (values ,final t ,consumedp))))
 373
 374                ;; If there's a separator, prime the pump by parsing a first
 375                ;; item.  This makes the loop easy: it just parses a separator
 376                ;; and an item each time.  And it means we don't need a
 377                ;; counter in the case of a minimum of 1.
 378                ,@(and sepp
 379                       `((multiple-value-bind (,value ,win ,cp)
 380                             (parse ,parser)
 381                           (when ,cp (setf ,consumedp t))
 382                           (unless ,win
 383                             ,(cond ((eql min 0)
 384                                     `(,done))
 385                                    ((and (numberp min) (plusp min))
 386                                     `(return-from ,block
 387                                        (values ,value nil ,consumedp)))
 388                                    (t
 389                                     `(if (< 0 ,min)
 390                                          (return-from ,block
 391                                            (values ,value nil, consumedp))
 392                                          (,done)))))
 393                           ,@(and acc `((,up ,value))))
 394                         ,@(and counterp `((incf ,i)))))
 395
 396                ;; The main loop...
 397                (loop
 398
 399                  ;; If we've hit the maximum then stop.  But, attention, if
 400                  ;; we have a separator and we're not committing to parsing
 401                  ;; items, then check after scanning the separator, not
 402                  ;; before.
 403                  ,@(and max commitp
 404                         `((when (and ,@(and (not (constantp max))
 405                                             `(,max))
 406                                      ,@(and (not (constantp commitp))
 407                                             `(,commitp))
 408                                      (>= ,i ,max))
 409                             (,done))))
 410
 411                  ,@(if sepp
 412                        ;; We're expecting a separator.  If this fails and
 413                        ;; we're below minimum then we've failed altogether.
 414                        ;; If it succeeds then we should go on to parse an
 415                        ;; item.
 416                        `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
 417                            ,@(and (numberp min) (<= min 1)
 418                                   `((declare (ignore ,value))))
 419                            (when ,cp (setf ,consumedp t))
 420                            (unless ,win
 421                              ,(if (and (numberp min) (<= min 1))
 422                                   `(,done)
 423                                   `(if (>= ,i ,min)
 424                                        (return ,final)
 425                                        (return-from ,block
 426                                          (values ,value nil ,consumedp))))))
 427
 428                          ;; If we're not committing then now is the time to
 429                          ;; check for hitting the maximum number of
 430                          ;; repetitions.
 431                          ,@(and max (or (not commitp)
 432                                         (not (constantp commitp)))
 433                                 `((when (and ,@(and (not (constantp max))
 434                                                     `(,max))
 435                                              ,@(and commitp
 436                                                     `((not ,commitp)))
 437                                              (>= ,i ,max))
 438                                     (,done))))
 439
 440                          ;; Now parse an item.  If this fails and we're
 441                          ;; committed then we've blown the whole parse.  If
 442                          ;; it fails and we've not committed then we need to
 443                          ;; check the minimum.  It's getting very tempting to
 444                          ;; write a compiler for optimizing these
 445                          ;; conditionals.  (If we don't do this, we get
 446                          ;; annoying warnings.)
 447                          (multiple-value-bind (,value ,win ,cp)
 448                              (parse ,parser)
 449                            (when ,cp (setf ,consumedp t))
 450                            (unless ,win
 451                              ,(cond ((and (constantp commitp) commitp)
 452                                      `(return-from ,block
 453                                         (values ,value nil ,consumedp)))
 454                                     ((not commitp)
 455                                      (if (and (numberp min) (<= min 1))
 456                                          `(,done)
 457                                          `(if (>= ,i ,min)
 458                                               (,done)
 459                                               (return-from ,block
 460                                                 (values ,value nil
 461                                                         ,consumedp)))))
 462                                     ((and (numberp min) (<= min 1))
 463                                      `(if ,commitp
 464                                           (return-from ,block
 465                                             (values ,value nil ,consumedp))
 466                                           (,done)))
 467                                     (t
 468                                      `(if (or ,commitp (< ,i ,min))
 469                                           (return-from ,block
 470                                             (values ,value nil ,consumedp))
 471                                           (,done)))))
 472                            ,@(and acc `((,up ,value)))))
 473
 474                        ;; No separator.  Just parse the value.  If it fails,
 475                        ;; check that we've met the minimum.
 476                        `((multiple-value-bind (,value ,win ,cp)
 477                              (parse ,parser)
 478                            ,@(and (eql min 0) (null acc)
 479                                   `((declare (ignore ,value))))
 480                            (when ,cp (setf ,consumedp t))
 481                            (unless ,win
 482                              ,(if (eql min 0)
 483                                   `(,done)
 484                                   `(if (>= ,i ,min)
 485                                        (,done)
 486                                        (return-from ,block
 487                                          (values ,value nil ,consumedp)))))
 488                           ,@(and acc `((,up ,value))))))
 489
 490                  ;; Done.  Update the counter and go round again.
 491                  ,@(and counterp `((incf ,i)))))))))))