[PATCH 1/2] Add (guix build build-flags).

[Alex Vong <alexvong1995@gmail.com>]

From 6ad35e245c374ff828f167bb3467ce68559ccefd Mon Sep 17 00:00:00 2001
From: Alex Vong <alexvong1995@gmail.com>
Date: Sat, 31 Oct 2015 19:44:13 +0800
Subject: [PATCH 1/2] Add (guix build build-flags).

A module to manipulate build flags, similar to dpkg-buildflags.

* guix/build/build-flags.scm: New file.
* Makefile.am (MODULES): Register it.
---
 Makefile.am                |   1 +
 guix/build/build-flags.scm | 271 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 272 insertions(+)
 create mode 100644 guix/build/build-flags.scm

diff --git a/Makefile.am b/Makefile.am
index b2ee324..c62cb8b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -71,6 +71,7 @@ MODULES =					\
   guix/svn-download.scm				\
   guix/ui.scm					\
   guix/build/download.scm			\
+  guix/build/build-flags.scm			\
   guix/build/cmake-build-system.scm		\
   guix/build/emacs-build-system.scm		\
   guix/build/git.scm				\
diff --git a/guix/build/build-flags.scm b/guix/build/build-flags.scm
new file mode 100644
index 0000000..30a35a1
--- /dev/null
+++ b/guix/build/build-flags.scm
@@ -0,0 +1,271 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Alex Vong <alexvong1995@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build build-flags)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (flag-list
+            flag-list+
+            flag-list-
+            flag-list->string-list
+            default-flag-list
+            format-flag-list
+            fortify-flag-list
+            stackprotector-flag-list
+            stackprotectorstrong-flag-list
+            relro-flag-list
+            bindnow-flag-list
+            pie-flag-list
+            all-flag-list))
+
+;;; Commentary:
+;;;
+;;; Module to manipulate build flags, similar to dpkg-buildflags.
+;;;
+;;; Data structure <flag-list> is constructed by flag-list.
+;;; The constructor flag-list does something to its arguments,
+;;; such as trimming white-spaces, to ensure no two arguments mean the same.
+;;;
+;;; Here is an example:
+;;; (define default-flag-list
+;;;   (flag-list
+;;;    #:CFLAGS '("-O2" "-g")
+;;;    #:LDFLAGS '("-lm" "-lpthread")))
+;;;
+;;; flag-list+ and flag-list- are analogous to
+;;; numeric + and - but operate on <flag-list>.
+;;;
+;;; flag-list->string-list converts <flag-list> into
+;;; configure-flags-compatible string-list.
+;;;
+;;; Code:
+
+
+;;; Pair up a symbol with a procedure so that we know
+;;; what identifier is bound to the procedure at macro-expand time.
+(define-record-type <identifier-procedure-pair>
+  (cons-identifier-procedure id proc)
+  identifier-procedure-pair?
+  (id identifier)
+  (proc procedure))
+
+(define-syntax define-record-type-with-accessor-list
+  (syntax-rules ()
+    "Macro to define a srfi-9 record
+with accessor list bound to accessor-list-name.
+"
+    ((_ record-name
+        (constructor-name field-name* ...)
+        predicate-name
+        accessor-list-name
+        (field-name accessor-name) ...)
+     (begin
+       (define-record-type record-name
+         (constructor-name field-name* ...)
+         predicate-name
+         (field-name accessor-name) ...)
+       (define accessor-list-name
+         `(,(cons-identifier-procedure 'accessor-name
+                                       accessor-name) ...))))))
+
+;;; define <flag-list> using define-record-type-with-accessor-list macro
+(define-record-type-with-accessor-list <flag-list>
+  (make-flag-list c-flags
+                  cpp-flags
+                  c++-flags
+                  fc-flags
+                  f-flags
+                  gcj-flags
+                  ld-flags
+                  objc-flags
+                  objc++-flags)
+  flag-list?
+  flag-list-accessor-list
+  (c-flags CFLAGS)
+  (cpp-flags CPPFLAGS)
+  (c++-flags CXXFLAGS)
+  (fc-flags FCFLAGS)
+  (f-flags FFLAGS)
+  (gcj-flags GCJFLAGS)
+  (ld-flags LDFLAGS)
+  (objc-flags OBJCFLAGS)
+  (objc++-flags OBJCXXFLAGS))
+
+
+(define-syntax define*-with-keyword-list
+  (syntax-rules ()
+    "Macro to define a procedure with keyword and default arguments
+only with keyword list bound to keyword-list-name.
+"
+    ((_ (proc-name keyword-list-name
+                   (keyword default-val) ...)
+        body)
+     (begin
+       (define* (proc-name #:key
+                           (keyword default-val) ...)
+         body)
+       (define keyword-list-name
+         (map symbol->keyword
+              '(keyword ...)))))))
+
+;;; Constructor for <flag-list>
+;;; with keyword list bound to flag-list-keyword-list.
+(define*-with-keyword-list (flag-list flag-list-keyword-list
+                                      (CFLAGS '())
+                                      (CPPFLAGS '())
+                                      (CXXFLAGS '())
+                                      (FCFLAGS '())
+                                      (FFLAGS '())
+                                      (GCJFLAGS '())
+                                      (LDFLAGS '())
+                                      (OBJCFLAGS '())
+                                      (OBJCXXFLAGS '()))
+  (apply make-flag-list
+         (map (lambda (string-list)
+                (map string-trim-both string-list))
+              (list CFLAGS
+                    CPPFLAGS
+                    CXXFLAGS
+                    FCFLAGS
+                    FFLAGS
+                    GCJFLAGS
+                    LDFLAGS
+                    OBJCFLAGS
+                    OBJCXXFLAGS))))
+
+(define (keyword-apply proc kw-list kw-arg-list by-position-arg-list)
+  "keyword-apply is inspired by the same-name procedure in Racket.
+It applies a procedure using keyword list and keyword argument list.
+"
+  (apply proc
+         (append (concatenate (zip kw-list
+                                   kw-arg-list))
+                 by-position-arg-list)))
+
+
+(define (flag-list-operation lset-operation)
+  "Take a lset operation.
+Return a procedure that takes any number of <flag-list>
+and does the set operation on them for each flags respectively
+"
+  (define (list-of-string-list-operation list-of-string-list)
+    (apply lset-operation
+           `(,string=? ,@list-of-string-list)))
+  (lambda list-of-flag-list
+    (let ((flag-list-proc-list (map procedure
+                                    flag-list-accessor-list)))
+      (keyword-apply flag-list
+                     flag-list-keyword-list
+                     (map (lambda (proc)
+                            (list-of-string-list-operation
+                             (map proc list-of-flag-list)))
+                          flag-list-proc-list)
+                   '()))))
+
+;;; union any number of <flag-list> for each flags
+(define flag-list+
+  (flag-list-operation lset-union))
+
+;;; take the first <flag-list> and minus the union of the rest for each flags
+(define flag-list-
+  (flag-list-operation lset-difference))
+
+(define (flag-list->string-list flag-lst)
+  "Convert <flag-list> into configure-flags-compatible string list.
+"
+  (map (lambda (accessor)
+         (let ((id (identifier accessor))
+               (proc (procedure accessor)))
+           (string-append (symbol->string id)
+                          "="
+                          (string-join (proc flag-lst)))))
+       flag-list-accessor-list))
+
+
+;;; build flags used in dpkg-buildflags
+
+(define default-flag-list
+  (flag-list
+   #:CFLAGS '("-g" "-O2")
+   #:CXXFLAGS '("-g" "-O2")
+   #:FCFLAGS '("-g" "-O2")
+   #:FFLAGS '("-g" "-O2")
+   #:GCJFLAGS '("-g" "-O2")
+   #:OBJCFLAGS '("-g" "-O2")
+   #:OBJCXXFLAGS '("-g" "-O2")))
+
+(define format-flag-list
+  (flag-list
+   #:CFLAGS '("-Wformat" "-Werror=format-security")
+   #:CXXFLAGS '("-Wformat" "-Werror=format-security")
+   #:OBJCFLAGS '("-Wformat" "-Werror=format-security")
+   #:OBJCXXFLAGS '("-Wformat" "-Werror=format-security")))
+
+(define fortify-flag-list
+  (flag-list
+   #:CPPFLAGS '("-D_FORTIFY_SOURCE=2")))
+
+(define stackprotector-flag-list
+  (flag-list
+   #:CFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:CXXFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:FCFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:FFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:GCJFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:OBJCFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")
+   #:OBJCXXFLAGS '("-fstack-protector" "--param=ssp-buffer-size=4")))
+
+(define stackprotectorstrong-flag-list
+  (flag-list
+   #:CFLAGS '("-fstack-protector-strong")
+   #:CXXFLAGS '("-fstack-protector-strong")
+   #:FCFLAGS '("-fstack-protector-strong")
+   #:FFLAGS '("-fstack-protector-strong")
+   #:GCJFLAGS '("-fstack-protector-strong")
+   #:OBJCFLAGS '("-fstack-protector-strong")
+   #:OBJCXXFLAGS '("-fstack-protector-strong")))
+
+(define relro-flag-list
+  (flag-list
+   #:LDFLAGS '("-Wl,-z,relro")))
+
+(define bindnow-flag-list
+  (flag-list
+   #:LDFLAGS '("-Wl,-z,now")))
+
+(define pie-flag-list
+  (flag-list
+   #:CFLAGS '("-fPIE")
+   #:CXXFLAGS '("-fPIE")
+   #:FCFLAGS '("-fPIE")
+   #:FFLAGS '("-fPIE")
+   #:GCJFLAGS '("-fPIE")
+   #:LDFLAGS '("-fPIE" "-pie")
+   #:OBJCFLAGS '("-fPIE")
+   #:OBJCXXFLAGS '("-fPIE")))
+
+(define all-flag-list
+  (flag-list+ default-flag-list
+              format-flag-list
+              fortify-flag-list
+              stackprotectorstrong-flag-list
+              relro-flag-list
+              bindnow-flag-list
+              pie-flag-list))
+
+;;; build-flags.scm ends here
-- 
2.1.4