|
|
@@ -0,0 +1,396 @@
|
|
|
+#!/bin/sh
|
|
|
+# -*- mode: scheme; coding: utf-8; -*-
|
|
|
+GUILE_AUTO_COMPILE=0
|
|
|
+export GUILE_AUTO_COMPILE
|
|
|
+main='(@ (run-test) build/run)'
|
|
|
+exec "${GUILE-@GUILE@}" -l "$0" \
|
|
|
+ -c "(apply $main (cdr (command-line)))" "$@"
|
|
|
+!#
|
|
|
+;;; GCC-StarPU
|
|
|
+;;; Copyright (C) 2011 Institut National de Recherche en Informatique et Automatique
|
|
|
+;;;
|
|
|
+;;; GCC-StarPU 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.
|
|
|
+;;;
|
|
|
+;;; GCC-StarPU 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 GCC-StarPU. If not, see <http://www.gnu.org/licenses/>.
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; Written by Ludovic Courtès <ludovic.courtes@inria.fr>.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define-module (run-test)
|
|
|
+ #:use-module (ice-9 regex)
|
|
|
+ #:use-module (ice-9 popen)
|
|
|
+ #:use-module (ice-9 rdelim)
|
|
|
+ #:use-module (ice-9 format)
|
|
|
+ #:use-module (ice-9 match)
|
|
|
+ #:use-module (srfi srfi-1)
|
|
|
+ #:use-module (srfi srfi-9)
|
|
|
+ #:use-module (srfi srfi-11)
|
|
|
+ #:use-module (srfi srfi-13)
|
|
|
+ #:use-module (srfi srfi-14)
|
|
|
+ #:use-module (srfi srfi-26)
|
|
|
+ #:export (build/run))
|
|
|
+
|
|
|
+;;; Commentary:
|
|
|
+;;;
|
|
|
+;;; Test machinery similary to the DejaGNU-based test framework used in GCC.
|
|
|
+;;; In a nutshell, this program compiles code with GCC and makes sure
|
|
|
+;;; warnings and errors are as appear in source code comments.
|
|
|
+;;;
|
|
|
+;;; This module should work with both Guile 1.8 and Guile 2.0.
|
|
|
+;;;
|
|
|
+;;; Code:
|
|
|
+
|
|
|
+;; Make sure the reader gets position information.
|
|
|
+(read-enable 'positions)
|
|
|
+
|
|
|
+(define %log-port
|
|
|
+ ;; Output port for debugging messages.
|
|
|
+ (current-output-port))
|
|
|
+
|
|
|
+(define (log fmt . args)
|
|
|
+ "Write an informational message."
|
|
|
+ (apply format %log-port (string-append fmt "\n") args))
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; Compiling code.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define %srcdir "@srcdir@")
|
|
|
+(define %builddir "@builddir@")
|
|
|
+(define %gcc "@CC@")
|
|
|
+
|
|
|
+(define %default-cflags
|
|
|
+ `("-I" ,%srcdir
|
|
|
+ "-I" ,(string-append %srcdir "/../../include")
|
|
|
+ "-I" ,(string-append %builddir "/../../include")
|
|
|
+ "-I" ,(string-append %builddir "/../..")
|
|
|
+
|
|
|
+ ;; Unfortunately `libtool --mode=execute' doesn't help here, so hard-code
|
|
|
+ ;; the real file name.
|
|
|
+ ,(string-append "-fplugin=" %builddir "/../src/.libs/starpu.so")
|
|
|
+
|
|
|
+ "-dH" "-fdump-tree-gimple" "-Wall"))
|
|
|
+
|
|
|
+(define %default-ldflags
|
|
|
+ `(,(string-append "-L" %srcdir "/../../src")))
|
|
|
+
|
|
|
+(define %libtool
|
|
|
+ (string-append %builddir "/../../libtool"))
|
|
|
+
|
|
|
+
|
|
|
+(define (compile-starpu-code file cc cflags ldflags)
|
|
|
+ "Compile and link FILE with CC, using CFLAGS and LDFLAGS. Return the
|
|
|
+compiler status and the list of lines printed on stdout/stderr."
|
|
|
+ (let* ((compile? (member "-c" cflags))
|
|
|
+ (ldflags (if compile?
|
|
|
+ (remove (cut string-prefix? "-L" <>) ldflags)
|
|
|
+ ldflags))
|
|
|
+ (mode (if compile?
|
|
|
+ "compile"
|
|
|
+ "link"))
|
|
|
+ (command (format #f "LANG=C ~a --mode=~a ~a ~{~a ~} \"~a\" ~{~a ~} 2>&1"
|
|
|
+ %libtool mode cc cflags file ldflags))
|
|
|
+ (pipe (begin
|
|
|
+ (log "running `~a'" command)
|
|
|
+ (open-input-pipe command))))
|
|
|
+ (let loop ((line (read-line pipe))
|
|
|
+ (result '()))
|
|
|
+ (if (eof-object? line)
|
|
|
+ (values (close-pipe pipe) (reverse result))
|
|
|
+ (loop (read-line pipe)
|
|
|
+ (cons line result))))))
|
|
|
+
|
|
|
+(define (run-starpu-code executable)
|
|
|
+ "Run EXECUTABLE using Libtool; return its exit status."
|
|
|
+ (let* ((exe (if (string-index executable #\/)
|
|
|
+ executable
|
|
|
+ (string-append (getcwd) "/" executable)))
|
|
|
+ (command (string-append %libtool " --mode=execute "
|
|
|
+ exe)))
|
|
|
+ (log "running `~a'" command)
|
|
|
+ (system command)))
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; GCC diagnostics.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define-record-type <location>
|
|
|
+ (make-location file line column)
|
|
|
+ location?
|
|
|
+ (file location-file)
|
|
|
+ (line location-line)
|
|
|
+ (column location-column))
|
|
|
+
|
|
|
+(define (location=? loc1 loc2)
|
|
|
+ "Return #t if LOC1 and LOC2 refer roughly to the same file and line
|
|
|
+number."
|
|
|
+ (and (location-file loc1) (location-file loc2)
|
|
|
+ (string=? (basename (location-file loc1))
|
|
|
+ (basename (location-file loc2)))
|
|
|
+ (= (location-line loc1) (location-line loc2))))
|
|
|
+
|
|
|
+(define-record-type <diagnostic>
|
|
|
+ (make-diagnostic location kind message)
|
|
|
+ diagnostic?
|
|
|
+ (location diagnostic-location)
|
|
|
+ (kind diagnostic-kind)
|
|
|
+ (message diagnostic-message))
|
|
|
+
|
|
|
+(define %diagnostic-with-location-rx
|
|
|
+ ;; "FILE:LINE:COL: KIND: MESSAGE..."
|
|
|
+ (make-regexp "^(.+):([[:digit:]]+):([[:digit:]]+): ([^:]+): (.*)$"))
|
|
|
+
|
|
|
+(define (string->diagnostic str)
|
|
|
+ "Parse STR and return the corresponding `diagnostic' object."
|
|
|
+ (cond ((regexp-exec %diagnostic-with-location-rx str)
|
|
|
+ =>
|
|
|
+ (lambda (m)
|
|
|
+ (let ((loc (make-location (match:substring m 1)
|
|
|
+ (string->number (match:substring m 2))
|
|
|
+ (string->number (match:substring m 3))))
|
|
|
+ (kind (string->symbol (match:substring m 4))))
|
|
|
+ (make-diagnostic loc kind (match:substring m 5)))))
|
|
|
+ (else
|
|
|
+ (make-diagnostic #f #f str))))
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; Reading test directives.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define (read-test-directives port)
|
|
|
+ "Read test directives from PORT. Return a list of location/directive
|
|
|
+pairs."
|
|
|
+ (define (consume-whitespace p)
|
|
|
+ (let loop ((chr (peek-char p)))
|
|
|
+ (cond ((char-set-contains? char-set:whitespace chr)
|
|
|
+ (read-char p) ;; consume CHR
|
|
|
+ (loop (peek-char p)))
|
|
|
+ (else chr))))
|
|
|
+
|
|
|
+ (define (read-until-*/ p)
|
|
|
+ (let loop ((chr (read-char p)))
|
|
|
+ (cond ((eof-object? chr)
|
|
|
+ (error "unterminated C comment"))
|
|
|
+ ((eq? chr #\*)
|
|
|
+ (let ((next (peek-char p)))
|
|
|
+ (if (eq? next #\/)
|
|
|
+ (read-char p) ;; consume CHR
|
|
|
+ (loop (read-char p)))))
|
|
|
+ (else
|
|
|
+ (loop (read-char p))))))
|
|
|
+
|
|
|
+ (let loop ((chr (read-char port))
|
|
|
+ (directives '()))
|
|
|
+ (cond ((eof-object? chr)
|
|
|
+ (reverse directives))
|
|
|
+ ((eq? chr #\/)
|
|
|
+ (let ((chr (read-char port)))
|
|
|
+ (if (eq? chr #\*)
|
|
|
+ (let ((chr (consume-whitespace port)))
|
|
|
+ (if (eq? chr #\()
|
|
|
+ (let ((loc (make-location (port-filename port)
|
|
|
+ (1+ (port-line port))
|
|
|
+ (port-column port)))
|
|
|
+ (sexp (read port)))
|
|
|
+ (read-until-*/ port)
|
|
|
+ (loop (peek-char port)
|
|
|
+ (cons (cons loc sexp)
|
|
|
+ directives)))
|
|
|
+ (begin
|
|
|
+ (read-until-*/ port)
|
|
|
+ (loop (peek-char port) directives))))
|
|
|
+ (loop chr directives))))
|
|
|
+ (else
|
|
|
+ (loop (read-char port) directives)))))
|
|
|
+
|
|
|
+(define (diagnostic-matches-directive? diagnostic directive location)
|
|
|
+ "Return #t if DIAGNOSTIC matches DIRECTIVE, which is at LOCATION."
|
|
|
+ (and (location? (diagnostic-location diagnostic))
|
|
|
+ (location=? (diagnostic-location diagnostic) location)
|
|
|
+ (match directive
|
|
|
+ ((kind message)
|
|
|
+ (and (eq? kind (diagnostic-kind diagnostic))
|
|
|
+ (string-match message (diagnostic-message diagnostic)))))))
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; Compiling and matching diagnostics against directives.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define (compile/match* file directives cc cflags ldflags)
|
|
|
+ "Compile FILE and check whether GCC's diagnostics match DIRECTIVES. Return
|
|
|
+3 values: the compiler's status code, the unmatched diagnostics, and the
|
|
|
+unsatisfied directives."
|
|
|
+ (let-values (((status diagnostics)
|
|
|
+ (compile-starpu-code file cc cflags ldflags)))
|
|
|
+ (let loop ((diagnostics (map string->diagnostic diagnostics))
|
|
|
+ (directives directives)
|
|
|
+ (unsatisfied '()))
|
|
|
+ (if (null? directives)
|
|
|
+ (values status diagnostics unsatisfied)
|
|
|
+ (let* ((dir (car directives))
|
|
|
+ (diag (find (cute diagnostic-matches-directive?
|
|
|
+ <> (cdr dir) (car dir))
|
|
|
+ diagnostics)))
|
|
|
+ (if diag
|
|
|
+ (loop (delq diag diagnostics)
|
|
|
+ (cdr directives)
|
|
|
+ unsatisfied)
|
|
|
+ (loop diagnostics
|
|
|
+ (cdr directives)
|
|
|
+ (cons dir unsatisfied))))))))
|
|
|
+
|
|
|
+(define (executable-file source)
|
|
|
+ "Return the name of the executable file corresponding to SOURCE."
|
|
|
+ (let ((dot (string-rindex source #\.)))
|
|
|
+ (if dot
|
|
|
+ (substring source 0 dot)
|
|
|
+ (string-append source ".exe"))))
|
|
|
+
|
|
|
+(define (compile/match file cc cflags ldflags)
|
|
|
+ "Read directives from FILE, and compiler/link/run it. Make sure directives
|
|
|
+are matched, and report any errors otherwise. Return #t on success and #f
|
|
|
+otherwise."
|
|
|
+ (define directives
|
|
|
+ (call-with-input-file file read-test-directives))
|
|
|
+
|
|
|
+ (define exe
|
|
|
+ (executable-file file))
|
|
|
+
|
|
|
+ (log "~a directives found in `~a'" (length directives) file)
|
|
|
+
|
|
|
+ (let*-values (((error-expected?)
|
|
|
+ (find (lambda (l+d)
|
|
|
+ (match l+d
|
|
|
+ (((? location?) 'error _)
|
|
|
+ #t)
|
|
|
+ (_ #f)))
|
|
|
+ directives))
|
|
|
+ ((instructions)
|
|
|
+ (or (any (lambda (l+d)
|
|
|
+ (match l+d
|
|
|
+ (((? location?) 'instructions x ...)
|
|
|
+ x)
|
|
|
+ (_ #f)))
|
|
|
+ directives)
|
|
|
+ '(run)))
|
|
|
+ ((goal)
|
|
|
+ (if error-expected?
|
|
|
+ 'compile
|
|
|
+ (car instructions)))
|
|
|
+ ((cflags)
|
|
|
+ `(,@cflags
|
|
|
+ ,@(or (and=> (assq-ref (cdr instructions) 'cflags) cadr)
|
|
|
+ '())
|
|
|
+ ,@(if (memq goal '(link run))
|
|
|
+ `("-o" ,exe)
|
|
|
+ '("-c"))))
|
|
|
+ ((ldflags)
|
|
|
+ `(,@ldflags
|
|
|
+ ,@(or (assq-ref (cdr instructions) 'ldflags)
|
|
|
+ '())))
|
|
|
+ ((directives)
|
|
|
+ (remove (lambda (l+d)
|
|
|
+ (match l+d
|
|
|
+ (((? location?) 'instructions _ ...)
|
|
|
+ #t)
|
|
|
+ (_ #f)))
|
|
|
+ directives))
|
|
|
+ ((status diagnostics unsatisfied)
|
|
|
+ (compile/match* file directives cc cflags ldflags))
|
|
|
+ ((unmatched)
|
|
|
+ ;; Consider unmatched only diagnostics that have a kind, to
|
|
|
+ ;; avoid taking into account messages like "In file included
|
|
|
+ ;; from", "In function 'main'", etc.
|
|
|
+ (filter diagnostic-kind diagnostics)))
|
|
|
+
|
|
|
+ (or (null? unmatched)
|
|
|
+ (begin
|
|
|
+ (format (current-error-port)
|
|
|
+ "error: ~a unmatched GCC diagnostics:~%"
|
|
|
+ (length unmatched))
|
|
|
+ (for-each (lambda (d)
|
|
|
+ (format (current-error-port)
|
|
|
+ " ~a:~a:~a: ~a: ~a~%"
|
|
|
+ (and=> (diagnostic-location d)
|
|
|
+ location-file)
|
|
|
+ (and=> (diagnostic-location d)
|
|
|
+ location-line)
|
|
|
+ (and=> (diagnostic-location d)
|
|
|
+ location-column)
|
|
|
+ (diagnostic-kind d)
|
|
|
+ (diagnostic-message d)))
|
|
|
+ unmatched)
|
|
|
+ #f))
|
|
|
+
|
|
|
+ (if (null? unsatisfied)
|
|
|
+ (or (null? directives)
|
|
|
+ (log "~a directives satisfied" (length directives)))
|
|
|
+ (begin
|
|
|
+ (format (current-error-port) "error: ~a unsatisfied directives:~%"
|
|
|
+ (length unsatisfied))
|
|
|
+ (for-each (lambda (l+d)
|
|
|
+ (let ((loc (car l+d))
|
|
|
+ (dir (cdr l+d)))
|
|
|
+ (format (current-error-port)
|
|
|
+ " ~a:~a:~a: ~a: ~s~%"
|
|
|
+ (location-file loc)
|
|
|
+ (location-line loc)
|
|
|
+ (location-column loc)
|
|
|
+ (car dir)
|
|
|
+ (cadr dir))))
|
|
|
+ unsatisfied)
|
|
|
+ #f))
|
|
|
+
|
|
|
+ (if error-expected?
|
|
|
+ (if (= 0 status)
|
|
|
+ (format (current-error-port) "error: compilation succeeded~%"))
|
|
|
+ (if (= 0 status)
|
|
|
+ (or (eq? goal 'compile)
|
|
|
+ (file-exists? exe)
|
|
|
+ (begin
|
|
|
+ (format (current-error-port)
|
|
|
+ "error: executable file `~a' not found~%" exe)
|
|
|
+ #f))
|
|
|
+ (format (current-error-port)
|
|
|
+ "error: compilation failed (compiler exit code ~a)~%~{ ~a~%~}"
|
|
|
+ status
|
|
|
+ (map diagnostic-message diagnostics))))
|
|
|
+
|
|
|
+ (and (null? unmatched)
|
|
|
+ (null? unsatisfied)
|
|
|
+ (if error-expected?
|
|
|
+ (not (= 0 status))
|
|
|
+ (and (= 0 status)
|
|
|
+ (or (eq? goal 'compile) (file-exists? exe))
|
|
|
+ (or (not (eq? goal 'run))
|
|
|
+ (let ((status (run-starpu-code exe)))
|
|
|
+ (or (= 0 status)
|
|
|
+ (begin
|
|
|
+ (format (current-error-port)
|
|
|
+ "error: program `~a' failed (exit code ~a)~%"
|
|
|
+ exe status)
|
|
|
+ #f)))))))))
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+;;; Entry point.
|
|
|
+;;;
|
|
|
+
|
|
|
+(define (build/run . file)
|
|
|
+ (exit (every (cut compile/match <> %gcc %default-cflags %default-ldflags) file)))
|
|
|
+
|
|
|
+;;; run-test.in ends here
|
Ludovic Courtès