add (figl glu)

[clinton/guile-figl.git] / maint / update-low-level-bindings

diff --git a/maint/update-low-level-bindings b/maint/update-low-level-bindings
index 81a0858..5764bc2 100755 (executable)
--- a/maint/update-low-level-bindings
+++ b/maint/update-low-level-bindings
@@ -3,6 +3,7 @@
 
 (use-modules (figl parse)
              (figl config)
+             (ice-9 match)
              (sxml fold)
              ((srfi srfi-1) #:select (append-map))
              (texinfo serialize)
@@ -13,17 +14,23 @@
 
 (print-disable 'escape-newlines)
 
+(define (list-intersperse src-l elem)
+  (if (null? src-l) src-l
+      (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
+        (if (null? l) (reverse dest)
+            (loop (cdr l) (cons (car l) (cons elem dest)))))))
+
 (define (module-name->scm-name mod-name)
-  (in-vicinity
-   (abs-top-srcdir)
-   (string-append (string-join (map symbol->string mod-name) "/")
-                  ".scm")))
+  (string-join (list (abs-top-srcdir)
+                     "figl"
+                     (symbol->string mod-name)
+                     "low-level.scm")
+               "/"))
 
 (define (module-name->texi-name mod-name)
   (in-vicinity
    (in-vicinity (abs-top-srcdir) "doc")
-   (string-append (string-join (map symbol->string (cdr mod-name)) "-")
-                  ".texi")))
+   (string-append "low-level-" (symbol->string mod-name) ".texi")))
 
 (define (unique-copyrights defs)
   (let lp ((in defs) (out '()))
@@ -76,22 +83,22 @@
 " port)
   (newline port)
   (pretty-print
-   `(define-module ,mod-name
-      #:use-module (figl low-level support)
-      #:export ,(map (lambda (def)
-                       (string->symbol (gl-definition-name def)))
-                     defs))
+   `(define-module (figl ,mod-name low-level)
+      #:use-module (figl ,mod-name runtime)
+      #:use-module (figl ,mod-name types)
+      #:export ,(append-map (lambda (def)
+                              (map car (gl-definition-prototypes def)))
+                            defs))
    port)
   (newline port)
   (for-each
    (lambda (def)
      (pretty-print
-      `(define-gl-procedure ,(string->symbol (gl-definition-name def))
-         ,(gl-definition-name def)
-         ,(gl-definition-prototype def)
-         ,(string-trim-both
-           (stexi->plain-text
-            (gl-definition-documentation def))))
+      `(,(symbol-append 'define- mod-name '-procedures)
+        ,(gl-definition-prototypes def)
+        ,(string-trim-both
+          (stexi->plain-text
+           (gl-definition-documentation def))))
       port)
      (newline port))
    defs))
@@ -102,7 +109,7 @@
     `(*fragment*
       (para "The functions from this section may be had by loading "
             "the module:")
-      (example "(use-modules " ,(object->string mod-name) ")")
+      (example "(use-modules (figl " ,(object->string mod-name) " low-level)")
       (copying
        (para
         "This section of the manual was derived from the upstream "
@@ -113,11 +120,24 @@
        ,@(append-map cdr (unique-copyrights defs)))
       ,@(map
          (lambda (def)
-           `(defun (% (name ,(gl-definition-name def))
-                      ;; FIXME: proper prototype.
-                      ;; (gl-definition-prototype def)
-                      (arguments))
-              ,@(cdr (gl-definition-documentation def))))
+           (match (gl-definition-prototypes def)
+             (((name (pname ptype) ... '-> return-type)
+               (name* (pname* ptype*) ... '-> return-type*)
+               ...)
+              `(deftypefun (% (name ,(symbol->string name))
+                              (data-type ,(symbol->string return-type))
+                              (arguments ,@(list-intersperse
+                                            (map symbol->string pname)
+                                            " ")))
+                 ,@(map (lambda (name pname ptype return-type)
+                          `(deftypefunx
+                             (% (name ,(symbol->string name))
+                                (data-type ,(symbol->string return-type))
+                                (arguments ,@(list-intersperse
+                                              (map symbol->string pname)
+                                              " ")))))
+                        name* pname* ptype* return-type*)
+                 ,@(cdr (gl-definition-documentation def))))))
          defs)))
    port))
 
@@ -148,9 +168,9 @@
   (call-with-values
       (lambda () (partition-definitions version))
     (lambda (gl glu glx)
-      (write-bindings '(figl low-level gl) (reverse gl))
-      (write-bindings '(figl low-level glu) (reverse glu))
-      (write-bindings '(figl low-level glx) (reverse glx)))))
+      (write-bindings 'gl (reverse gl))
+      (write-bindings 'glu (reverse glu))
+      (write-bindings 'glx (reverse glx)))))
 
 (when (batch-mode?)
   (apply main (command-line)))