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