diff options
Diffstat (limited to 'module/system/base/target.scm')
-rw-r--r-- | module/system/base/target.scm | 76 |
1 files changed, 76 insertions, 0 deletions
diff --git a/module/system/base/target.scm b/module/system/base/target.scm new file mode 100644 index 000000000..573ccca46 --- /dev/null +++ b/module/system/base/target.scm @@ -0,0 +1,76 @@ +;;; Compilation targets + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system base target) + #:use-module (rnrs bytevectors) + #:export (target-type with-target + + target-cpu target-vendor target-os + + target-endianness target-word-size)) + + + +;;; +;;; Target types +;;; + +(define %target-type (make-fluid)) + +(define (target-type) + (or (fluid-ref %target-type) + %host-type)) + +(define (validate-target target) + (if (or (not (string? target)) + (let ((parts (string-split target #\-))) + (or (< 3 (length parts)) + (or-map string-null? parts)))) + (error "invalid target" target))) + +(define (with-target target thunk) + (validate-target target) + (with-fluids ((%target-type target)) + (thunk))) + +(define (target-cpu) + (let ((t (target-type))) + (substring t 0 (string-index t #\-)))) + +(define (target-vendor) + (let* ((t (target-type)) + (start (1+ (string-index t #\-)))) + (substring t start (string-index t #\- start)))) + +(define (target-os) + (let* ((t (target-type)) + (start (1+ (string-index t #\- (1+ (string-index t #\-)))))) + (substring t start))) + +(define (target-endianness) + (if (equal? (target-type) %host-type) + (native-endianness) + (error "cross-compilation not yet handled" %host-type (target-type)))) + +(define (target-word-size) + (if (equal? (target-type) %host-type) + ((@ (system foreign) sizeof) '*) + (error "cross-compilation not yet handled" %host-type (target-type)))) |