4 (use-modules (figl parse)
8 ((srfi srfi-1) #:select (append-map))
15 (print-disable 'escape-newlines)
17 (define (list-intersperse src-l elem)
18 (if (null? src-l) src-l
19 (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
20 (if (null? l) (reverse dest)
21 (loop (cdr l) (cons (car l) (cons elem dest)))))))
23 (define (module-name->scm-name mod-name)
24 (string-join (list (abs-top-srcdir)
26 (symbol->string mod-name)
30 (define (module-name->texi-name mod-name)
32 (in-vicinity (abs-top-srcdir) "doc")
33 (string-append "low-level-" (symbol->string mod-name) ".texi")))
35 (define (unique-copyrights defs)
36 (let lp ((in defs) (out '()))
39 (let ((copyright (gl-definition-copyright (car in))))
41 (if (or (not copyright) (member copyright out))
43 (cons copyright out)))))))
45 (define (write-scm mod-name defs port)
47 ;;; figl -*- mode: scheme; coding: utf-8 -*-
48 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
50 ;;; Figl is free software: you can redistribute it and/or modify it
51 ;;; under the terms of the GNU Lesser General Public License as
52 ;;; published by the Free Software Foundation, either version 3 of the
53 ;;; License, or (at your option) any later version.
55 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
56 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
57 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
58 ;;; Public License for more details.
60 ;;; You should have received a copy of the GNU Lesser General Public
61 ;;; License along with this program. If not, see
62 ;;; <http://www.gnu.org/licenses/>.
64 ;;; Derived from upstream OpenGL documentation.
70 (for-each (lambda (line)
75 (string-trim-both (stexi->plain-text copyright))
77 (unique-copyrights defs))
80 ;;; Automatically generated; you probably don't want to edit this. To
81 ;;; update, run \"make update\" in the top-level build tree.
86 `(define-module (figl ,mod-name low-level)
87 #:use-module (figl ,mod-name runtime)
88 #:use-module (figl ,mod-name types)
89 #:export ,(append-map (lambda (def)
90 (map car (gl-definition-prototypes def)))
97 `(,(symbol-append 'define- mod-name '-procedures)
98 ,(gl-definition-prototypes def)
101 (gl-definition-documentation def))))
106 (define (write-texi mod-name defs port)
110 (para "The functions from this section may be had by loading "
112 (example "(use-modules (figl " ,(object->string mod-name) " low-level)")
115 "This section of the manual was derived from the upstream "
116 "OpenGL documentation. Each function's documentation has "
117 "its own copyright statement; for full details, see the "
118 "upstream documentation. The copyright notices and licenses "
119 "present in this section are as follows.")
120 ,@(append-map cdr (unique-copyrights defs)))
123 (match (gl-definition-prototypes def)
124 (((name (pname ptype) ... '-> return-type)
125 (name* (pname* ptype*) ... '-> return-type*)
127 `(deftypefun (% (name ,(symbol->string name))
128 (data-type ,(symbol->string return-type))
129 (arguments ,@(list-intersperse
130 (map symbol->string pname)
132 ,@(map (lambda (name pname ptype return-type)
134 (% (name ,(symbol->string name))
135 (data-type ,(symbol->string return-type))
136 (arguments ,@(list-intersperse
137 (map symbol->string pname)
139 name* pname* ptype* return-type*)
140 ,@(cdr (gl-definition-documentation def))))))
144 (define (write-bindings mod-name defs)
145 (call-with-output-file (module-name->scm-name mod-name)
147 (write-scm mod-name defs port)))
148 (call-with-output-file (module-name->texi-name mod-name)
150 (write-texi mod-name defs port))))
152 (define (partition-definitions version)
154 (lambda (def gl glu glx)
156 ((string-prefix? "glu" (gl-definition-name def))
157 (values gl (cons def glu) glx))
158 ((string-prefix? "glX" (gl-definition-name def))
159 (values gl glu (cons def glx)))
161 (values (cons def gl) glu glx))))
162 (parse-gl-definitions version)
167 (define* (main arg0 #:optional (version "2"))
169 (lambda () (partition-definitions version))
171 (write-bindings 'gl (reverse gl))
172 (write-bindings 'glu (reverse glu))
173 (write-bindings 'glx (reverse glx)))))
176 (apply main (command-line)))