figl/parse.scm

   1 ;;; figl
   2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   3 ;;;
   4 ;;; Figl is free software: you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  10 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  11 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  12 ;;; Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;
  20 ;; figl is the Foreign Interface to GL.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (figl parse)
  25   #:use-module (figl config)
  26   #:use-module (figl contrib)
  27   #:use-module (sxml simple)
  28   #:use-module ((sxml xpath) #:hide (filter))
  29   #:use-module (sxml transform)
  30   #:use-module (sxml fold)
  31   #:use-module ((srfi srfi-1) #:select (filter fold append-map filter-map))
  32   #:use-module (srfi srfi-9) ; define-record-type
  33   #:use-module (srfi srfi-42) ; eager comprehensions
  34   #:use-module (texinfo docbook)
  35   #:use-module (ice-9 ftw)
  36   #:use-module (ice-9 rdelim)
  37   #:use-module (ice-9 match)
  38   #:use-module (ice-9 regex)
  39   #:export (gl-definition?
  40             make-gl-definition
  41             gl-definition-name
  42             gl-definition-prototypes
  43             gl-definition-documentation
  44             gl-definition-copyright
  45             parse-gl-definitions
  46
  47             gl-enumeration?
  48             make-gl-enumeration
  49             gl-enumeration-category
  50             gl-enumeration-values
  51             parse-gl-enumerations
  52
  53             gl-param-type?
  54             make-gl-param-type
  55             gl-param-type-type
  56             gl-param-type-direction
  57             gl-param-type-transfer-type
  58             parse-gl-type-map))
  59
  60 (define-record-type gl-definition
  61   (make-gl-definition name prototypes documentation copyright)
  62   gl-definition?
  63   (name gl-definition-name)
  64   (prototypes gl-definition-prototypes)
  65   (documentation gl-definition-documentation)
  66   (copyright gl-definition-copyright))
  67
  68 ;; values := (name . number) ...
  69 (define-record-type gl-enumeration
  70   (make-gl-enumeration category values)
  71   gl-enumeration?
  72   (category gl-enumeration-category)
  73   (values gl-enumeration-values))
  74
  75 ;; Seed of gl-param and more.
  76 ;; TODO: Is this not really gl-type?
  77 (define-record-type gl-param-type
  78   (%make-gl-param-type type direction transfer-type)
  79   gl-param-type?
  80   (type gl-param-type-type)
  81   (direction gl-param-type-direction)
  82   (transfer-type gl-param-type-transfer-type))
  83
  84 ;; Memoized for eq?, hash, memory usage.
  85 (define make-gl-param-type (memoize %make-gl-param-type))
  86
  87 (define *namespaces*
  88   '((mml . "http://www.w3.org/1998/Math/MathML")))
  89
  90 (define *entities*
  91   '(;; From http://www.w3.org/TR/MathML2/mmlextra.html
  92     (af . "\u2061") ;; Function application.
  93     (it . "\u2062") ;; Invisible times.
  94     ;; http://www.w3.org/TR/MathML2/isonum.html
  95     (plus . "\u002B") ;; Plus sign.
  96     (times . "\u00D7") ;; Multiplication sign.
  97     ;; http://www.w3.org/TR/MathML2/isotech.html
  98     (Prime . "\u2033") ;; Double prime.
  99     (le . "\u2264") ;; Less than or equal to.
 100     (ne . "\u2260") ;; Not equal to.
 101     (minus . "\u2212") ;; Minus sign.
 102     ;; http://www.w3.org/TR/MathML2/isoamsc.html
 103     (lceil . "\u2308") ;; Left ceiling.
 104     (rceil . "\u2309") ;; Right ceiling.
 105     (lfloor . "\u230A") ;; Left floor.
 106     (rfloor . "\u230B") ;; Right floor.
 107     ;; http://www.w3.org/TR/MathML2/mmlalias.html
 108     (DoubleVerticalBar . "\u2225") ;; Parallel to.
 109     (LeftFloor . "\u230A") ;; Left floor.
 110     (RightFloor . "\u230B") ;; Right floor.
 111     (LeftCeiling . "\u2308") ;; Left ceiling.
 112     (RightCeiling . "\u2309") ;; Right ceiling.
 113     (CenterDot . "\u00B7") ;; Middle dot.
 114     (VerticalBar . "\u2223") ;; Divides.
 115     (PartialD . "\u2202") ;; Partial derivative.
 116     ;; http://www.w3.org/TR/MathML2/mmlextra.html
 117     (Hat . "\u005E") ;; Circumflex accent.
 118     ;; http://www.w3.org/TR/MathML2/isogrk3.html
 119     (Delta . "\u0394") ;; Greek capital letter delta.
 120     (Sigma . "\u03A3") ;; Greek capital letter sigma.
 121     ;; Misc.
 122     (nbsp . "\u00A0")
 123     ))
 124
 125 (define (default-entity-handler port name)
 126   (format (current-warning-port)
 127           "~a:~a:~a: undefined entitity: &~a;\n"
 128           (or (port-filename port) "<unknown file>")
 129           (port-line port) (port-column port)
 130           name)
 131   (symbol->string name))
 132
 133 (define dbmathml
 134   "http://www.oasis-open.org/docbook/xml/mathml/1.1CR1/dbmathml.dtd")
 135
 136 (define (docbook-with-mathml-handler docname systemid internal)
 137   (unless (equal? systemid dbmathml)
 138     (warn "unexpected doctype" docname systemid internal))
 139   (values #:entities *entities* #:namespaces *namespaces*))
 140
 141 (define (trim-whitespace-left str)
 142   (let ((first (and (not (string-null? str))
 143                     (string-ref str 0))))
 144     (if (and first (char-whitespace? first))
 145         (string-append (string first) (string-trim str char-whitespace?))
 146         str)))
 147
 148 (define (trim-whitespace-right str)
 149   (let ((last (and (not (string-null? str))
 150                    (string-ref str (1- (string-length str))))))
 151     (if (and last (char-whitespace? last))
 152         (string-append (string-trim-right str char-whitespace?) (string last))
 153         str)))
 154
 155 (define (trim-whitespace str)
 156   (trim-whitespace-left
 157    (trim-whitespace-right str)))
 158
 159 (define (zap-whitespace sxml)
 160   (define (not-whitespace x)
 161     (or (not (string? x))
 162         (not (string-every char-whitespace? x))))
 163   (pre-post-order sxml
 164                   `((*default* . ,(lambda (tag . body)
 165                                     (cons tag
 166                                           (filter not-whitespace body))))
 167                     (*text* . ,(lambda (tag text)
 168                                  (if (string? text)
 169                                      (trim-whitespace text)
 170                                      text))))))
 171
 172 (define (parse-man-xml version filename)
 173   (define subdir (format #f "man~A" version))
 174   (call-with-input-file (in-vicinity (upstream-doc)
 175                                      (in-vicinity subdir filename))
 176     (lambda (port)
 177       (zap-whitespace
 178        (xml->sxml port #:declare-namespaces? #t
 179                   #:default-entity-handler default-entity-handler
 180                   #:doctype-handler docbook-with-mathml-handler)))))
 181
 182 (define (xml-files version)
 183   (define subdir (format #f "man~A" version))
 184   (scandir (in-vicinity (upstream-doc) subdir)
 185            (lambda (x) (string-suffix? ".xml" x))))
 186
 187 (define (take-first proc)
 188   (lambda (xml)
 189     (let ((res (proc xml)))
 190       (and (pair? res) (car res)))))
 191
 192 (define xml-name
 193   (take-first (sxpath '(refentry refnamediv refname *text*))))
 194
 195 (define xml-purpose
 196   (take-first (sxpath '(refentry refnamediv refpurpose *text*))))
 197
 198 (define xml-funcprototypes
 199   (sxpath '(refentry refsynopsisdiv funcsynopsis funcprototype)))
 200
 201 (define xml-parameters
 202   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "parameters")))))))
 203
 204 (define xml-description
 205   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "description")))))))
 206
 207 (define xml-errors
 208   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "errors")))))))
 209
 210 (define xml-copyright
 211   (take-first (sxpath '(refentry (refsect1 (@ id (equal? "Copyright")))))))
 212
 213 (define (string->gl-type str)
 214   (string->symbol
 215    (string-join (string-split (string-trim-both str) #\space) "-")))
 216
 217 (define (parse-prototypes sxml)
 218   (define all-names
 219     (match sxml
 220       ((('funcprototype ('funcdef return-type ('function names))
 221                         . _)
 222         ...)
 223        names)))
 224
 225   (define (redundant-variant? s shun-suffix prefer-suffix)
 226     (and (string-suffix? shun-suffix s)
 227          (member (string-append (substring s 0 (- (string-length s)
 228                                                   (string-length shun-suffix)))
 229                                 prefer-suffix)
 230                  all-names)))
 231
 232   (filter-map
 233    (lambda (sxml)
 234      (match sxml
 235        (('funcprototype ('funcdef return-type ('function name))
 236                         ('paramdef ('parameter "void")))
 237         `(,(string->symbol name)
 238           -> ,(string->gl-type return-type)))
 239        (('funcprototype ('funcdef return-type ('function name))
 240                         ('paramdef ptype ('parameter pname))
 241                         ...)
 242         `(,(string->symbol name)
 243           ,@(map (lambda (pname ptype)
 244                    (list (string->symbol pname)
 245                          (string->gl-type ptype)))
 246                  pname ptype)
 247           -> ,(string->gl-type return-type)))))
 248    sxml))
 249
 250 (define (collapse-fragments nodeset)
 251   (match nodeset
 252     ((('*fragment* elts ...) nodes ...)
 253      (append (collapse-fragments elts)
 254              (collapse-fragments nodes)))
 255     ((((and tag (? symbol?)) elts ...) nodes ...)
 256      (acons tag (collapse-fragments elts) (collapse-fragments nodes)))
 257     ((elt nodes ...)
 258      (cons elt (collapse-fragments nodes)))
 259     (() '())))
 260
 261 (define (list-intersperse src-l elem)
 262   (if (null? src-l) src-l
 263       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
 264         (if (null? l) (reverse dest)
 265             (loop (cdr l) (cons (car l) (cons elem dest)))))))
 266
 267 (define (lift-tables sdocbook)
 268   ;; Like sdocbook-flatten, but tweaked to lift tables from inside
 269   ;; paras, but not paras from inside tables.  Pretty hacky stuff.
 270   (define *sdocbook-block-commands*
 271     '(informaltable programlisting variablelist))
 272
 273   (define (inline-command? command)
 274     (not (memq command *sdocbook-block-commands*)))
 275
 276   (define (fhere str accum block cont)
 277     (values (cons str accum)
 278             block
 279             cont))
 280   (define (fdown node accum block cont)
 281     (match node
 282       ((command (and attrs ('% . _)) body ...)
 283        (values body '() '()
 284                (lambda (accum block)
 285                  (values
 286                   `(,command ,attrs ,@(reverse accum))
 287                   block))))
 288       ((command body ...)
 289        (values body '() '()
 290                (lambda (accum block)
 291                  (values
 292                   `(,command ,@(reverse accum))
 293                   block))))))
 294   (define (fup node paccum pblock pcont kaccum kblock kcont)
 295     (call-with-values (lambda () (kcont kaccum kblock))
 296       (lambda (ret block)
 297         (if (inline-command? (car ret))
 298             (values (cons ret paccum) (append kblock pblock) pcont)
 299             (values paccum (append kblock (cons ret pblock)) pcont)))))
 300   (call-with-values
 301       (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
 302     (lambda (accum block cont)
 303       (append (reverse accum)
 304               (reverse block)
 305               ))))
 306
 307 (define *rules*
 308   `((refsect1
 309      *preorder*
 310      . ,(lambda (tag id . body)
 311           (append-map (lambda (nodeset)
 312                         (map
 313                          (lambda (x)
 314                            (pre-post-order x *rules*))
 315                          nodeset))
 316                       (map lift-tables
 317                            (match body
 318                              ((('title _) body ...) body)
 319                              (_ body))))))
 320     (variablelist
 321      ((varlistentry
 322        . ,(lambda (tag term . body)
 323             `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
 324       (listitem
 325        . ,(lambda (tag . body)
 326             (map (lambda (x)
 327                    (if (string? x)
 328                        `(para ,x)
 329                        x))
 330                  body)))
 331       (term
 332        . ,(lambda (tag . rest)
 333             `((itemx ,@rest)))))
 334      . ,(lambda (tag . body)
 335           `(table (% (formatter (asis))) ,@body)))
 336     (trademark
 337      . ,(match-lambda*
 338          ((_ ('@ ('class "copyright"))) '(copyright))))
 339     (parameter
 340      . ,(lambda (tag body)
 341           `(var ,body)))
 342     (type
 343      . ,(lambda (tag body)
 344           `(code ,body)))
 345     (constant
 346      . ,(lambda (tag . body)
 347           `(code . ,body)))
 348     (code
 349      . ,(lambda (tag . body)
 350           `(code . ,body)))
 351     (function
 352      . ,(lambda (tag body . ignored)
 353           (or (null? ignored) (warn "ignored function tail" ignored))
 354           `(code ,body)))
 355     (emphasis
 356      . ,(match-lambda*
 357          ((_) "")
 358          ((_ ('@ ('role "bold")) (and body (? string?)))
 359           `(strong ,(string-trim-both body)))
 360          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
 361          ((_ body) `(var ,body))))
 362     (citerefentry
 363      . ,(lambda (tag contents)
 364           contents))
 365     (refentrytitle
 366      . ,(lambda (tag contents)
 367           `(code ,contents)))
 368     (inlineequation
 369      . ,(lambda (tag contents)
 370           contents))
 371     (informalequation
 372      . ,(lambda (tag contents)
 373           contents))
 374     (informaltable
 375      . ,(lambda (tag attrs tgroup)
 376           tgroup))
 377     (tgroup
 378      ((thead
 379        . ,(lambda (tag . rows)
 380             rows))
 381       (colspec
 382        . ,(lambda _
 383             #f))
 384       (tbody
 385        . ,(lambda (tag . rows)
 386             rows))
 387       (row
 388        . ,(lambda (tag first . rest)
 389             `(entry (% (heading ,@first))
 390                     (para ,@(apply
 391                              append
 392                              (list-intersperse rest '(", ")))))))
 393       (entry
 394        . ,(match-lambda*
 395            ((_) '())
 396            ((_ ('@ . _)) '())
 397            ((_ ('@ . _) x ...) x)
 398            ((_ x ...) x))))
 399      . ,(lambda (tag attrs . contents)
 400           `(table (% (formatter (asis)))
 401                   ,@(apply append (filter identity contents)))))
 402
 403     ;; Poor man's mathml.
 404     (mml:math
 405      . ,(lambda (tag . contents)
 406           `(r . ,(collapse-fragments contents))))
 407     (mml:mn
 408      . ,(lambda (tag n . rest)
 409           (if (pair? rest)
 410               `(*fragment* ,n . ,rest)
 411               n)))
 412     (mml:mi
 413      . ,(case-lambda
 414           ((tag contents)
 415            `(code ,contents))
 416           ((tag attrs contents)
 417            (match attrs
 418              (('@ (mathvariant "italic"))
 419               `(var ,contents))
 420              (_ `(code ,contents))))))
 421     ;; It would be possible to represent a matrix as a @multitable, but
 422     ;; Guile doesn't really have support for that.  So instead print
 423     ;; each row in parentheses.
 424     (mml:mtable
 425      ((mml:mtr
 426        . ,(lambda (tag . body)
 427             `("(" ,@(list-intersperse body " ") ")")))
 428       (mml:mtd
 429        . ,(match-lambda*
 430            ((tag ('@ . _) body ...)
 431             `(*fragment* ,@body))
 432            ((tag body ...)
 433             `(*fragment* ,@body)))))
 434      . ,(lambda (tag . rows)
 435           ;; Rely on outer mfence for outer parens, if any
 436           (let ((rows (if (and (pair? rows) (eq? (caar rows) '@))
 437                           (cdr rows)
 438                           rows)))
 439             `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
 440     (mml:mspace
 441      . ,(lambda (tag . _)
 442           " "))
 443     (mml:msup
 444      . ,(lambda (tag base exponent)
 445           `(*fragment* ,base "^" ,exponent)))
 446     (mml:msub
 447      . ,(lambda (tag base exponent)
 448           `(*fragment* ,base "_" ,exponent)))
 449     (mml:mover
 450      . ,(lambda (tag base over)
 451           `(*fragment* ,base ,over)))
 452     (mml:munderover
 453      . ,(lambda (tag under base over)
 454           `(*fragment* ,under ,base ,over)))
 455     (mml:mfrac
 456      . ,(lambda (tag num denom)
 457           `(*fragment* ,num "/" ,denom)))
 458     (mml:msqrt
 459      . ,(lambda (tag base)
 460           `(*fragment* "√" ,base)))
 461     (mml:infinity
 462      . ,(lambda (tag)
 463           "∞"))
 464     (mml:mo
 465      . ,(lambda (tag operator)
 466           operator))
 467     (mml:mrow
 468      . ,(lambda (tag . contents)
 469           `(*fragment* . ,contents)))
 470     (mml:mfenced
 471      . ,(lambda (tag attrs left . right)
 472           `(*fragment* ,@(assq-ref attrs 'open)
 473                        ,left
 474                        ","
 475                        ,@right
 476                        ,@(assq-ref attrs 'close))))
 477     (*text*
 478      . ,(lambda (tag text)
 479           text))
 480     ,@*sdocbook->stexi-rules*))
 481
 482 (define (sdocbook->stexi sdocbook)
 483   (pre-post-order sdocbook *rules*))
 484
 485 ;; Produces an stexinfo fragment.
 486 (define (generate-documentation purpose parameters description errors)
 487   `(*fragment*
 488     (para ,(string-append (string (char-upcase (string-ref purpose 0)))
 489                           (substring purpose 1)
 490                           "."))
 491     ,@(if parameters (sdocbook->stexi parameters) '())
 492     ,@(if description (sdocbook->stexi description) '())
 493     ,@(if errors (sdocbook->stexi errors) '())))
 494
 495 (define (xml->definition xml)
 496   (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
 497     (and (pair? prototypes)
 498          (make-gl-definition (xml-name xml)
 499                              prototypes
 500                              (generate-documentation (xml-purpose xml)
 501                                                      (xml-parameters xml)
 502                                                      (xml-description xml)
 503                                                      (xml-errors xml))
 504                              (and=> (xml-copyright xml)
 505                                     (lambda (c)
 506                                       `(*fragment* ,@(sdocbook->stexi c))))))))
 507
 508 (define (parse-gl-definitions version)
 509   (filter-map (lambda (file)
 510                 (xml->definition (parse-man-xml version file)))
 511               (xml-files version)))
 512
 513 (define (trim-comment line)
 514   (cond
 515    ((string-index line #\#)
 516     => (lambda (idx) (substring line 0 idx)))
 517    (else line)))
 518
 519 (define (expand-camel-case s)
 520   (define (add-humps humps out more?)
 521     (match humps
 522       (() out)
 523       ((head)
 524        (if (null? out)
 525            humps
 526            (cons* head #\- out)))
 527       ((head tail ...)
 528        (let ((out (if (null? out)
 529                       tail
 530                       (append tail (cons #\- out)))))
 531          (if more?
 532              (cons* head #\- out)
 533              (cons head out))))))
 534   (let lp ((in (string->list s)) (humps '()) (out '()))
 535     (match in
 536       (()
 537        (list->string (reverse (add-humps humps out #f))))
 538       ((c in ...)
 539        (if (and (char-lower-case? c)
 540                 ;; Try to keep subtokens like 12x3 in one piece.
 541                 (or (null? humps)
 542                     (not (and-map char-numeric? humps))))
 543            (lp in '() (cons c (add-humps humps out #t)))
 544            (lp in (cons (char-downcase c) humps) out))))))
 545
 546 (define (mangle-name name)
 547   (string->symbol
 548    (string-join (map expand-camel-case (string-split name #\_))
 549                 "-")))
 550
 551 (define (parse-number num)
 552   (cond
 553    ((equal? "0xFFFFFFFFu" num)
 554     #xFFFFFFFF)
 555    ((equal? "0xFFFFFFFFFFFFFFFFull" num)
 556     #xFFFFFFFFFFFFFFFF)
 557    ((string-prefix? "0x" num)
 558     (string->number (substring num 2) 16))
 559    ((string-prefix? "GL_" num)
 560     (cons #f (mangle-name (substring num 3))))
 561    ;; Hackety hack...
 562    ((string-prefix? "GLX_" num)
 563     (cons #f (mangle-name (substring num 4))))
 564    (else
 565     (string->number num))))
 566
 567 (define (read-line-and-trim-comment port)
 568   (let ((line (read-line port)))
 569     (if (eof-object? line)
 570         line
 571         (string-trim-both (trim-comment line)))))
 572
 573 (define (resolve-enumerations enums)
 574   ;; We shouldn't fail to resolve anything, but there are a couple bugs
 575   ;; in enum.spec currently:
 576   ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=787.  Until they
 577   ;; are fixed, allow resolution to fail.
 578   (define (resolve-value category name value)
 579     (match value
 580       (#f #f)
 581       ((? number?)
 582        value)
 583       ((#f . (and name (? symbol?)))
 584        (resolve-value category name category))
 585       ((? symbol?)
 586        (resolve-value value name (assq-ref (assq-ref enums value) name)))))
 587   (let lp ((in enums) (out '()))
 588     (match in
 589       (()
 590        (reverse out))
 591       (((category (name . value) ...) . in)
 592        (lp in
 593            (cons (make-gl-enumeration
 594                   category
 595                   (filter-map
 596                    (lambda (name value)
 597                      (and=> (resolve-value category name value)
 598                             (lambda (value)
 599                               (cons name value))))
 600                    name value))
 601                  out))))))
 602
 603 (define (merge-alists in)
 604   ;; O(n^2), whee
 605   (define (collect-values key values in)
 606     (let lp ((in in) (values values))
 607       (if (null? in)
 608           values
 609           (lp (cdr in)
 610               (if (eq? (caar in) key)
 611                   (append values (cdar in))
 612                   values)))))
 613   (let lp ((in in) (out '()))
 614     (cond
 615      ((null? in) (reverse out))
 616      ((assq (caar in) out) (lp (cdr in) out))
 617      (else (lp (cdr in)
 618                (acons (caar in)
 619                       (collect-values (caar in) (cdar in) (cdr in))
 620                       out))))))
 621
 622 (define (parse-enumerations-from-port port)
 623   (define (finish-block headers enums accum)
 624     (if (null? enums)
 625         accum
 626         (fold (lambda (header accum)
 627                 (acons header (reverse enums) accum))
 628               accum
 629               headers)))
 630   (let lp ((current-headers '()) (current-enums '()) (accum '()))
 631     (let ((line (read-line-and-trim-comment port)))
 632       (cond
 633        ((eof-object? line)
 634         (resolve-enumerations
 635          (merge-alists
 636           (reverse (finish-block current-headers current-enums accum)))))
 637        ((string-index line #\:)
 638         => (lambda (pos)
 639              (let* ((ws (or (string-index-right line char-whitespace? 0 pos) 0))
 640                     (headers (filter
 641                               (compose not string-null?)
 642                               (map string-trim-both
 643                                    (string-split (substring line 0 ws) #\,))))
 644                     (def (substring line (1+ ws) pos)))
 645                (match (cons def headers)
 646                  ((or ("define" _ ...)
 647                       ((? (lambda (x) (string-suffix? "_future_use" x)))))
 648                   (lp '()
 649                       '()
 650                       (finish-block current-headers current-enums accum)))
 651                  (("enum" headers ...)
 652                   (if (null? current-enums)
 653                       (lp (append current-headers (map mangle-name headers))
 654                           current-enums
 655                           accum)
 656                       (lp (map mangle-name headers)
 657                           '()
 658                           (finish-block current-headers current-enums accum))))
 659                  (x (error "qux." x))))))
 660        ((string-null? line)
 661         (lp current-headers current-enums accum))
 662        (else
 663         (match (filter (compose not string-null?)
 664                        (string-split (trim-comment line) char-whitespace?))
 665           ((enum "=" value)
 666            (lp current-headers
 667                (acons (mangle-name enum)
 668                       (or (parse-number value)
 669                           (error "failed to parse" value))
 670                       current-enums)
 671                accum))
 672           (("use" header enum)
 673            (lp current-headers
 674                (acons (mangle-name enum)
 675                       (mangle-name header)
 676                       current-enums)
 677                accum))
 678           (x (error x))))))))
 679
 680 (define (parse-gl-enumerations spec)
 681   (call-with-input-file (in-vicinity (upstream-doc)
 682                                      (in-vicinity "spec" spec))
 683     parse-enumerations-from-port))
 684
 685 \f
 686 ;;;
 687 ;;; Type Map
 688 ;;;
 689
 690 (define valid-directions '(in out in/out))
 691
 692 (define valid-transfer-types '(array reference value))
 693
 694 (define* (string->directions str #:optional
 695                              (expansion valid-directions))
 696   (let ((direction (string->symbol str)))
 697     (cond
 698      ((and (eq? direction '*) expansion)
 699       expansion)
 700      ((memq direction valid-directions)
 701       (list direction))
 702      (else
 703       (error "unknown direction" str)))))
 704
 705 (define* (string->transfer-types str #:optional
 706                                  (expansion valid-transfer-types))
 707   (let ((trans (string->symbol str)))
 708     (cond
 709      ((and (eq? trans '*) expansion)
 710       expansion)
 711      ((memq trans valid-transfer-types)
 712       (list trans))
 713      (else
 714       (error "unknown transfer-type" str)))))
 715
 716 (define (expand-type-map-entry type
 717                                direction
 718                                transfer-type
 719                                mapped-type
 720                                mapped-direction
 721                                mapped-transfer-type)
 722   (let ((type (mangle-name type))
 723         (mapped-type (string->gl-type mapped-type)))
 724     (list-ec (:list direction (string->directions direction))
 725              (:list transfer-type (string->transfer-types transfer-type))
 726              (:list mapped-direction
 727                     (string->directions mapped-direction
 728                                         (list direction)))
 729              (:list mapped-transfer-type
 730                     (string->transfer-types mapped-transfer-type
 731                                             (list transfer-type)))
 732              (cons (make-gl-param-type type
 733                                        direction
 734                                        transfer-type)
 735                    (make-gl-param-type mapped-type
 736                                        mapped-direction
 737                                        mapped-transfer-type)))))
 738
 739 (define (parse-type-map-from-port port)
 740   (define delimiter (make-regexp "[ \t]*,[ \t]*"))
 741
 742   (let lp ((accum '()))
 743     (let ((line (read-line-and-trim-comment port)))
 744       (cond
 745        ((eof-object? line)
 746         (reverse accum))
 747        ((string-null? line)
 748         (lp accum))
 749        (else
 750         ;; TODO: Filter needed here to avoid formatting bug:
 751         ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=790
 752         (match (filter (compose not string-null?)
 753                        (string-split line delimiter))
 754           ((type direction transfer-type
 755             mapped-type mapped-direction mapped-transfer-type)
 756            (lp (append (expand-type-map-entry type
 757                                               direction
 758                                               transfer-type
 759                                               mapped-type
 760                                               mapped-direction
 761                                               mapped-transfer-type)
 762                        accum)))
 763           (x (error x))))))))
 764
 765 (define (parse-gl-type-map tm)
 766   (call-with-input-file (in-vicinity (upstream-doc)
 767                                      (in-vicinity "spec" tm))
 768     parse-type-map-from-port))