mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-22 20:42:03 -08:00
112 lines
4.2 KiB
Common Lisp
Executable file
112 lines
4.2 KiB
Common Lisp
Executable file
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
;;;; CMPOS-RUN Executing auxiliary programs
|
|
|
|
(in-package "COMPILER")
|
|
|
|
#+(and cygwin (not ecl-min))
|
|
(ffi:clines "#include <stdlib.h>")
|
|
|
|
(defun safe-system (string)
|
|
(cmpnote "Invoking external command:~% ~A~%" string)
|
|
(let ((result (ext:system string)))
|
|
(unless (zerop result)
|
|
(cerror "Continues anyway."
|
|
"(SYSTEM ~S) returned non-zero value ~D"
|
|
string result))
|
|
result))
|
|
|
|
(defun save-directory (forms)
|
|
(let ((directory
|
|
(probe-file (make-pathname :name nil :type nil
|
|
:defaults *default-pathname-defaults*))))
|
|
(if directory
|
|
(let ((*default-pathname-defaults* directory)
|
|
(old-directory (ext:chdir directory)))
|
|
(unwind-protect
|
|
(funcall forms)
|
|
(ext:chdir old-directory)))
|
|
(funcall forms))))
|
|
|
|
(defmacro with-current-directory (&body forms)
|
|
`(save-directory #'(lambda () ,@forms)))
|
|
|
|
#+(and cygwin (not ecl-min))
|
|
(defun old-crappy-system (program args)
|
|
(let* ((command (format nil "~S~{ ~S~}" program args))
|
|
(base-string-command (si:copy-to-simple-base-string command))
|
|
(code (ffi:c-inline (base-string-command) (:object) :int
|
|
"system(#0->base_string.self)":one-liner t)))
|
|
(values nil code nil)))
|
|
|
|
(defun safe-run-program (program args)
|
|
(cmpnote "Invoking external command:~% ~A ~{~A ~}" program args)
|
|
(multiple-value-bind (stream result process)
|
|
(let* ((*standard-output* ext:+process-standard-output+)
|
|
(*error-output* ext:+process-error-output+))
|
|
(with-current-directory
|
|
#-(and cygwin (not ecl-min))
|
|
(ext:run-program program args :input nil :output t :error t :wait t)
|
|
#+(and cygwin (not ecl-min))
|
|
(old-crappy-system program args)
|
|
))
|
|
(cond ((null result)
|
|
(cerror "Continues anyway."
|
|
"Unable to execute:~%(RUN-PROGRAM ~S ~S)"
|
|
program args result))
|
|
((not (zerop result))
|
|
(cerror "Continues anyway."
|
|
"Error code ~D when executing~%(RUN-PROGRAM ~S ~S)"
|
|
result program args)))
|
|
result))
|
|
|
|
(defun split-program-options (string)
|
|
(labels ((maybe-push (options current)
|
|
(if current
|
|
(cons current options)
|
|
options))
|
|
(new-string ()
|
|
(make-array 32 :element-type 'base-char :adjustable t
|
|
:fill-pointer 0))
|
|
(push-char (c s)
|
|
(unless s (setf s (new-string)))
|
|
(vector-push-extend c s)
|
|
s))
|
|
(loop with output = '()
|
|
with option = nil
|
|
with status = nil
|
|
for i from 0 below (length string)
|
|
for c = (char string i)
|
|
for now = (first status)
|
|
do (cond ((eq now #\')
|
|
(if (eq c #\')
|
|
(setf status (rest status))
|
|
(setf option (push-char c option))))
|
|
((eq now #\\)
|
|
(setf option (push-char c option)
|
|
status (rest status)))
|
|
((eq now #\")
|
|
(if (eq c #\")
|
|
(setf status (rest status))
|
|
(setf option (push-char c option))))
|
|
((member c '(#\\ #\' #\"))
|
|
(push c status))
|
|
((member c '(#\Space #\Tab #\Return #\Newline))
|
|
(setf output (maybe-push output option)
|
|
option nil))
|
|
(t
|
|
(setf option (push-char c option))))
|
|
finally (cond (status
|
|
(error "In split-program-options, unterminated option list:~%~S"
|
|
string))
|
|
(t
|
|
(return (nreverse (maybe-push output option))))))))
|