diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:26 -0800 |
commit | deda2c0fd8689349fea2a900199a76ff7ecb319e (patch) | |
tree | c9726d54a0806a9b0c75e6c82db8692aea0053cf /compile.scm | |
parent | 3278b75942bdbe706f7a0fba87729bb1e935b68b (diff) | |
download | scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip |
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'compile.scm')
-rwxr-xr-x | compile.scm | 112 |
1 files changed, 112 insertions, 0 deletions
diff --git a/compile.scm b/compile.scm new file mode 100755 index 0000000..ce96822 --- /dev/null +++ b/compile.scm @@ -0,0 +1,112 @@ +#! /bin/sh +:;exec scm -e"(set! *script* \"$0\")" -f$0 $* + +;; Copyright (C) 1992-2002 Free Software Foundation, Inc. +;; +;; This program 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 2, or (at your option) +;; any later version. +;; +;; This program 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 this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of SCM. +;; +;; The exception is that, if you link the SCM library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the SCM library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name SCM. If you copy +;; code from other Free Software Foundation releases into a copy of +;; SCM, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for SCM, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "compile.scm", Compile C ==> Scheme ==> object-file. +;;; Author: Aubrey Jaffer. + +(define (go-script) + (cond ((not *script*)) + ((and (<= 1 (- (length *argv*) *optind*)) + (not (eqv? #\- (string-ref (car (list-tail *argv* *optind*)) 0)))) + (apply compile-file (list-tail *argv* *optind*))) + (else + (display "\ +\ +Usage: compile.scm FILE1.scm FILE2.scm ... +\ + Compiles Scheme FILE1.scm FILE2.scm ... to an object file named + FILE1<object-suffix>, where <object-suffix> is the object file suffix + for your computer (for instance, `.o'). FILE1.scm must be in the + current directory; FILE2.scm ... can be in other directories. +" + (current-error-port)) + (exit #f)))) + +;;; This unusual autoload loads either the +;;; source or compiled version if present. +(if (not (defined? hobbit)) ;Autoload for hobbit +(define (hobbit . args) + (require 'hobbit) + (apply hobbit args))) + +(define (compile-file file . args) + (require 'glob) + (apply hobbit file args) + (let ((command + (list "build" + "-hsystem" + "-tdll" + (string-append "--compiler-options=-I" (implementation-vicinity)) + "-c" (replace-suffix file (scheme-file-suffix) ".c")))) + (require 'build) + (cond ((>= (verbose) 3) (write command) (newline))) + (build-from-whole-argv command))) + +(define (compile->executable name . args) + (define sfs (scheme-file-suffix)) + (require 'glob) + (for-each hobbit args) + (let ((inits (map (lambda (file) + (string-append "-iinit_" (replace-suffix file sfs ""))) + args)) + (files (map (lambda (file) + (string-append "-c" (replace-suffix file sfs ".c"))) + args))) + (define command (append (list "build" + "-hsystem" + "--type=exe" + "-o" name + "-F" "compiled-closure" "inexact" + (string-append "--linker-options=-L" + (implementation-vicinity))) + files + inits)) + (require 'build) + (cond ((>= (verbose) 3) (write command) (newline))) + (build-from-whole-argv command))) + +(go-script) + +;;; Local Variables: +;;; mode:scheme +;;; End: |