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   (define (skip? s)
 233     (or
 234      ;; Skip double variants if we have a float variant.
 235      ;; (http://www.opengl.org/wiki/Common_Mistakes#GL_DOUBLE).
 236      (redundant-variant? s "d" "f")
 237
 238      ;; Skip byte variants if there is a short variant.
 239      (redundant-variant? s "b" "s")
 240
 241      ;; Skip short variants if there is an int variant.
 242      (redundant-variant? s "s" "i")
 243
 244      ;; Skip packed setters like glVertex3fv if e.g. glVertex3f exists.
 245      (redundant-variant? s "v" "")
 246      (redundant-variant? s "dv" "fv")
 247      (redundant-variant? s "bv" "sv")
 248      (redundant-variant? s "sv" "iv")))
 249
 250   (filter-map
 251    (lambda (sxml)
 252      (match sxml
 253        (('funcprototype ('funcdef return-type ('function (? skip?)))
 254                         . _)
 255         #f)
 256        (('funcprototype ('funcdef return-type ('function name))
 257                         ('paramdef ('parameter "void")))
 258         `(,(string->symbol name)
 259           -> ,(string->gl-type return-type)))
 260        (('funcprototype ('funcdef return-type ('function name))
 261                         ('paramdef ptype ('parameter pname))
 262                         ...)
 263         `(,(string->symbol name)
 264           ,@(map (lambda (pname ptype)
 265                    (list (string->symbol pname)
 266                          (string->gl-type ptype)))
 267                  pname ptype)
 268           -> ,(string->gl-type return-type)))))
 269    sxml))
 270
 271 (define (collapse-fragments nodeset)
 272   (match nodeset
 273     ((('*fragment* elts ...) nodes ...)
 274      (append (collapse-fragments elts)
 275              (collapse-fragments nodes)))
 276     ((((and tag (? symbol?)) elts ...) nodes ...)
 277      (acons tag (collapse-fragments elts) (collapse-fragments nodes)))
 278     ((elt nodes ...)
 279      (cons elt (collapse-fragments nodes)))
 280     (() '())))
 281
 282 (define (list-intersperse src-l elem)
 283   (if (null? src-l) src-l
 284       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
 285         (if (null? l) (reverse dest)
 286             (loop (cdr l) (cons (car l) (cons elem dest)))))))
 287
 288 (define (lift-tables sdocbook)
 289   ;; Like sdocbook-flatten, but tweaked to lift tables from inside
 290   ;; paras, but not paras from inside tables.  Pretty hacky stuff.
 291   (define *sdocbook-block-commands*
 292     '(informaltable programlisting variablelist))
 293
 294   (define (inline-command? command)
 295     (not (memq command *sdocbook-block-commands*)))
 296
 297   (define (fhere str accum block cont)
 298     (values (cons str accum)
 299             block
 300             cont))
 301   (define (fdown node accum block cont)
 302     (match node
 303       ((command (and attrs ('% . _)) body ...)
 304        (values body '() '()
 305                (lambda (accum block)
 306                  (values
 307                   `(,command ,attrs ,@(reverse accum))
 308                   block))))
 309       ((command body ...)
 310        (values body '() '()
 311                (lambda (accum block)
 312                  (values
 313                   `(,command ,@(reverse accum))
 314                   block))))))
 315   (define (fup node paccum pblock pcont kaccum kblock kcont)
 316     (call-with-values (lambda () (kcont kaccum kblock))
 317       (lambda (ret block)
 318         (if (inline-command? (car ret))
 319             (values (cons ret paccum) (append kblock pblock) pcont)
 320             (values paccum (append kblock (cons ret pblock)) pcont)))))
 321   (call-with-values
 322       (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f))
 323     (lambda (accum block cont)
 324       (append (reverse accum)
 325               (reverse block)
 326               ))))
 327
 328 (define *rules*
 329   `((refsect1
 330      *preorder*
 331      . ,(lambda (tag id . body)
 332           (append-map (lambda (nodeset)
 333                         (map
 334                          (lambda (x)
 335                            (pre-post-order x *rules*))
 336                          nodeset))
 337                       (map lift-tables
 338                            (match body
 339                              ((('title _) body ...) body)
 340                              (_ body))))))
 341     (variablelist
 342      ((varlistentry
 343        . ,(lambda (tag term . body)
 344             `(entry (% (heading ,@(cdar term))) ,@(apply append body))))
 345       (listitem
 346        . ,(lambda (tag . body)
 347             (map (lambda (x)
 348                    (if (string? x)
 349                        `(para ,x)
 350                        x))
 351                  body)))
 352       (term
 353        . ,(lambda (tag . rest)
 354             `((itemx ,@rest)))))
 355      . ,(lambda (tag . body)
 356           `(table (% (formatter (asis))) ,@body)))
 357     (trademark
 358      . ,(match-lambda*
 359          ((_ ('@ ('class "copyright"))) '(copyright))))
 360     (parameter
 361      . ,(lambda (tag body)
 362           `(var ,body)))
 363     (type
 364      . ,(lambda (tag body)
 365           `(code ,body)))
 366     (constant
 367      . ,(lambda (tag . body)
 368           `(code . ,body)))
 369     (code
 370      . ,(lambda (tag . body)
 371           `(code . ,body)))
 372     (function
 373      . ,(lambda (tag body . ignored)
 374           (or (null? ignored) (warn "ignored function tail" ignored))
 375           `(code ,body)))
 376     (emphasis
 377      . ,(match-lambda*
 378          ((_) "")
 379          ((_ ('@ ('role "bold")) (and body (? string?)))
 380           `(strong ,(string-trim-both body)))
 381          ((_ ('@ ('role "bold")) . body) `(strong ,@body))
 382          ((_ body) `(var ,body))))
 383     (citerefentry
 384      . ,(lambda (tag contents)
 385           contents))
 386     (refentrytitle
 387      . ,(lambda (tag contents)
 388           `(code ,contents)))
 389     (inlineequation
 390      . ,(lambda (tag contents)
 391           contents))
 392     (informalequation
 393      . ,(lambda (tag contents)
 394           contents))
 395     (informaltable
 396      . ,(lambda (tag attrs tgroup)
 397           tgroup))
 398     (tgroup
 399      ((thead
 400        . ,(lambda (tag . rows)
 401             rows))
 402       (colspec
 403        . ,(lambda _
 404             #f))
 405       (tbody
 406        . ,(lambda (tag . rows)
 407             rows))
 408       (row
 409        . ,(lambda (tag first . rest)
 410             `(entry (% (heading ,@first))
 411                     (para ,@(apply
 412                              append
 413                              (list-intersperse rest '(", ")))))))
 414       (entry
 415        . ,(match-lambda*
 416            ((_) '())
 417            ((_ ('@ . _)) '())
 418            ((_ ('@ . _) x ...) x)
 419            ((_ x ...) x))))
 420      . ,(lambda (tag attrs . contents)
 421           `(table (% (formatter (asis)))
 422                   ,@(apply append (filter identity contents)))))
 423
 424     ;; Poor man's mathml.
 425     (mml:math
 426      . ,(lambda (tag . contents)
 427           `(r . ,(collapse-fragments contents))))
 428     (mml:mn
 429      . ,(lambda (tag n . rest)
 430           (if (pair? rest)
 431               `(*fragment* ,n . ,rest)
 432               n)))
 433     (mml:mi
 434      . ,(case-lambda
 435           ((tag contents)
 436            `(code ,contents))
 437           ((tag attrs contents)
 438            (match attrs
 439              (('@ (mathvariant "italic"))
 440               `(var ,contents))
 441              (_ `(code ,contents))))))
 442     ;; It would be possible to represent a matrix as a @multitable, but
 443     ;; Guile doesn't really have support for that.  So instead print
 444     ;; each row in parentheses.
 445     (mml:mtable
 446      ((mml:mtr
 447        . ,(lambda (tag . body)
 448             `("(" ,@(list-intersperse body " ") ")")))
 449       (mml:mtd
 450        . ,(match-lambda*
 451            ((tag ('@ . _) body ...)
 452             `(*fragment* ,@body))
 453            ((tag body ...)
 454             `(*fragment* ,@body)))))
 455      . ,(lambda (tag . rows)
 456           ;; Rely on outer mfence for outer parens, if any
 457           (let ((rows (if (and (pair? rows) (eq? (caar rows) '@))
 458                           (cdr rows)
 459                           rows)))
 460             `(*fragment* ,@(apply append (list-intersperse rows '(", ")))))))
 461     (mml:mspace
 462      . ,(lambda (tag . _)
 463           " "))
 464     (mml:msup
 465      . ,(lambda (tag base exponent)
 466           `(*fragment* ,base "^" ,exponent)))
 467     (mml:msub
 468      . ,(lambda (tag base exponent)
 469           `(*fragment* ,base "_" ,exponent)))
 470     (mml:mover
 471      . ,(lambda (tag base over)
 472           `(*fragment* ,base ,over)))
 473     (mml:munderover
 474      . ,(lambda (tag under base over)
 475           `(*fragment* ,under ,base ,over)))
 476     (mml:mfrac
 477      . ,(lambda (tag num denom)
 478           `(*fragment* ,num "/" ,denom)))
 479     (mml:msqrt
 480      . ,(lambda (tag base)
 481           `(*fragment* "√" ,base)))
 482     (mml:infinity
 483      . ,(lambda (tag)
 484           "∞"))
 485     (mml:mo
 486      . ,(lambda (tag operator)
 487           operator))
 488     (mml:mrow
 489      . ,(lambda (tag . contents)
 490           `(*fragment* . ,contents)))
 491     (mml:mfenced
 492      . ,(lambda (tag attrs left . right)
 493           `(*fragment* ,@(assq-ref attrs 'open)
 494                        ,left
 495                        ","
 496                        ,@right
 497                        ,@(assq-ref attrs 'close))))
 498     (*text*
 499      . ,(lambda (tag text)
 500           text))
 501     ,@*sdocbook->stexi-rules*))
 502
 503 (define (sdocbook->stexi sdocbook)
 504   (pre-post-order sdocbook *rules*))
 505
 506 ;; Produces an stexinfo fragment.
 507 (define (generate-documentation purpose parameters description errors)
 508   `(*fragment*
 509     (para ,(string-append (string (char-upcase (string-ref purpose 0)))
 510                           (substring purpose 1)
 511                           "."))
 512     ,@(if parameters (sdocbook->stexi parameters) '())
 513     ,@(if description (sdocbook->stexi description) '())
 514     ,@(if errors (sdocbook->stexi errors) '())))
 515
 516 (define (xml->definition xml)
 517   (let ((prototypes (parse-prototypes (xml-funcprototypes xml))))
 518     (and (pair? prototypes)
 519          (make-gl-definition (xml-name xml)
 520                              prototypes
 521                              (generate-documentation (xml-purpose xml)
 522                                                      (xml-parameters xml)
 523                                                      (xml-description xml)
 524                                                      (xml-errors xml))
 525                              (and=> (xml-copyright xml)
 526                                     (lambda (c)
 527                                       `(*fragment* ,@(sdocbook->stexi c))))))))
 528
 529 (define (parse-gl-definitions version)
 530   (filter-map (lambda (file)
 531                 (xml->definition (parse-man-xml version file)))
 532               (xml-files version)))
 533
 534 (define (trim-comment line)
 535   (cond
 536    ((string-index line #\#)
 537     => (lambda (idx) (substring line 0 idx)))
 538    (else line)))
 539
 540 (define (expand-camel-case s)
 541   (define (add-humps humps out more?)
 542     (match humps
 543       (() out)
 544       ((head)
 545        (if (null? out)
 546            humps
 547            (cons* head #\- out)))
 548       ((head tail ...)
 549        (let ((out (if (null? out)
 550                       tail
 551                       (append tail (cons #\- out)))))
 552          (if more?
 553              (cons* head #\- out)
 554              (cons head out))))))
 555   (let lp ((in (string->list s)) (humps '()) (out '()))
 556     (match in
 557       (()
 558        (list->string (reverse (add-humps humps out #f))))
 559       ((c in ...)
 560        (if (and (char-lower-case? c)
 561                 ;; Try to keep subtokens like 12x3 in one piece.
 562                 (or (null? humps)
 563                     (not (and-map char-numeric? humps))))
 564            (lp in '() (cons c (add-humps humps out #t)))
 565            (lp in (cons (char-downcase c) humps) out))))))
 566
 567 (define (mangle-name name)
 568   (string->symbol
 569    (string-join (map expand-camel-case (string-split name #\_))
 570                 "-")))
 571
 572 (define (parse-number num)
 573   (cond
 574    ((equal? "0xFFFFFFFFu" num)
 575     #xFFFFFFFF)
 576    ((equal? "0xFFFFFFFFFFFFFFFFull" num)
 577     #xFFFFFFFFFFFFFFFF)
 578    ((string-prefix? "0x" num)
 579     (string->number (substring num 2) 16))
 580    ((string-prefix? "GL_" num)
 581     (cons #f (mangle-name (substring num 3))))
 582    ;; Hackety hack...
 583    ((string-prefix? "GLX_" num)
 584     (cons #f (mangle-name (substring num 4))))
 585    (else
 586     (string->number num))))
 587
 588 (define (read-line-and-trim-comment port)
 589   (let ((line (read-line port)))
 590     (if (eof-object? line)
 591         line
 592         (string-trim-both (trim-comment line)))))
 593
 594 (define (resolve-enumerations enums)
 595   ;; We shouldn't fail to resolve anything, but there are a couple bugs
 596   ;; in enum.spec currently:
 597   ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=787.  Until they
 598   ;; are fixed, allow resolution to fail.
 599   (define (resolve-value category name value)
 600     (match value
 601       (#f #f)
 602       ((? number?)
 603        value)
 604       ((#f . (and name (? symbol?)))
 605        (resolve-value category name category))
 606       ((? symbol?)
 607        (resolve-value value name (assq-ref (assq-ref enums value) name)))))
 608   (let lp ((in enums) (out '()))
 609     (match in
 610       (()
 611        (reverse out))
 612       (((category (name . value) ...) . in)
 613        (lp in
 614            (cons (make-gl-enumeration
 615                   category
 616                   (filter-map
 617                    (lambda (name value)
 618                      (and=> (resolve-value category name value)
 619                             (lambda (value)
 620                               (cons name value))))
 621                    name value))
 622                  out))))))
 623
 624 (define (merge-alists in)
 625   ;; O(n^2), whee
 626   (define (collect-values key values in)
 627     (let lp ((in in) (values values))
 628       (if (null? in)
 629           values
 630           (lp (cdr in)
 631               (if (eq? (caar in) key)
 632                   (append values (cdar in))
 633                   values)))))
 634   (let lp ((in in) (out '()))
 635     (cond
 636      ((null? in) (reverse out))
 637      ((assq (caar in) out) (lp (cdr in) out))
 638      (else (lp (cdr in)
 639                (acons (caar in)
 640                       (collect-values (caar in) (cdar in) (cdr in))
 641                       out))))))
 642
 643 (define (parse-enumerations-from-port port)
 644   (define (finish-block headers enums accum)
 645     (if (null? enums)
 646         accum
 647         (fold (lambda (header accum)
 648                 (acons header (reverse enums) accum))
 649               accum
 650               headers)))
 651   (let lp ((current-headers '()) (current-enums '()) (accum '()))
 652     (let ((line (read-line-and-trim-comment port)))
 653       (cond
 654        ((eof-object? line)
 655         (resolve-enumerations
 656          (merge-alists
 657           (reverse (finish-block current-headers current-enums accum)))))
 658        ((string-index line #\:)
 659         => (lambda (pos)
 660              (let* ((ws (or (string-index-right line char-whitespace? 0 pos) 0))
 661                     (headers (filter
 662                               (compose not string-null?)
 663                               (map string-trim-both
 664                                    (string-split (substring line 0 ws) #\,))))
 665                     (def (substring line (1+ ws) pos)))
 666                (match (cons def headers)
 667                  ((or ("define" _ ...)
 668                       ((? (lambda (x) (string-suffix? "_future_use" x)))))
 669                   (lp '()
 670                       '()
 671                       (finish-block current-headers current-enums accum)))
 672                  (("enum" headers ...)
 673                   (if (null? current-enums)
 674                       (lp (append current-headers (map mangle-name headers))
 675                           current-enums
 676                           accum)
 677                       (lp (map mangle-name headers)
 678                           '()
 679                           (finish-block current-headers current-enums accum))))
 680                  (x (error "qux." x))))))
 681        ((string-null? line)
 682         (lp current-headers current-enums accum))
 683        (else
 684         (match (filter (compose not string-null?)
 685                        (string-split (trim-comment line) char-whitespace?))
 686           ((enum "=" value)
 687            (lp current-headers
 688                (acons (mangle-name enum)
 689                       (or (parse-number value)
 690                           (error "failed to parse" value))
 691                       current-enums)
 692                accum))
 693           (("use" header enum)
 694            (lp current-headers
 695                (acons (mangle-name enum)
 696                       (mangle-name header)
 697                       current-enums)
 698                accum))
 699           (x (error x))))))))
 700
 701 (define (parse-gl-enumerations spec)
 702   (call-with-input-file (in-vicinity (upstream-doc)
 703                                      (in-vicinity "spec" spec))
 704     parse-enumerations-from-port))
 705
 706 \f
 707 ;;;
 708 ;;; Type Map
 709 ;;;
 710
 711 (define valid-directions '(in out in/out))
 712
 713 (define valid-transfer-types '(array reference value))
 714
 715 (define* (string->directions str #:optional
 716                              (expansion valid-directions))
 717   (let ((direction (string->symbol str)))
 718     (cond
 719      ((eq? direction '*)
 720       expansion)
 721      ((memq direction expansion)
 722       (list direction))
 723      (else
 724       (error "unknown direction" str)))))
 725
 726 (define* (string->transfer-types str #:optional
 727                                  (expansion valid-transfer-types))
 728   (let ((trans (string->symbol str)))
 729     (cond
 730      ((eq? trans '*)
 731       expansion)
 732      ((memq trans expansion)
 733       (list trans))
 734      (else
 735       (error "unknown transfer-type" str)))))
 736
 737 (define (expand-type-map-entry type
 738                                direction
 739                                transfer-type
 740                                mapped-type
 741                                mapped-direction
 742                                mapped-transfer-type)
 743   (let ((type (mangle-name type))
 744         (mapped-type (string->gl-type mapped-type)))
 745     (list-ec (:list direction (string->directions direction))
 746              (:list transfer-type (string->transfer-types transfer-type))
 747              (:list mapped-direction
 748                     (string->directions mapped-direction
 749                                         (list direction)))
 750              (:list mapped-transfer-type
 751                     (string->transfer-types mapped-transfer-type
 752                                             (list transfer-type)))
 753              (cons (make-gl-param-type type
 754                                        direction
 755                                        transfer-type)
 756                    (make-gl-param-type mapped-type
 757                                        mapped-direction
 758                                        mapped-transfer-type)))))
 759
 760 (define (parse-type-map-from-port port)
 761   (define delimiter (make-regexp "[ \t]*,[ \t]*"))
 762
 763   (let lp ((accum '()))
 764     (let ((line (read-line-and-trim-comment port)))
 765       (cond
 766        ((eof-object? line)
 767         (reverse accum))
 768        ((string-null? line)
 769         (lp accum))
 770        (else
 771         ;; TODO: Filter needed here to avoid formatting bug:
 772         ;; http://www.khronos.org/bugzilla/show_bug.cgi?id=790
 773         (match (filter (compose not string-null?)
 774                        (string-split line delimiter))
 775           ((type direction transfer-type
 776             mapped-type mapped-direction mapped-transfer-type)
 777            (lp (append (expand-type-map-entry type
 778                                               direction
 779                                               transfer-type
 780                                               mapped-type
 781                                               mapped-direction
 782                                               mapped-transfer-type)
 783                        accum)))
 784           (x (error x))))))))
 785
 786 (define (parse-gl-type-map tm)
 787   (call-with-input-file (in-vicinity (upstream-doc)
 788                                      (in-vicinity "spec" tm))
 789     parse-type-map-from-port))