;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Alex Vong ;;; ;;; 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 . (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 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->string-list converts 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 (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 using define-record-type-with-accessor-list macro (define-record-type-with-accessor-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 ;;; 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 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 for each flags (define flag-list+ (flag-list-operation lset-union)) ;;; take the first 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 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