-
Notifications
You must be signed in to change notification settings - Fork 1
/
cl-portable.lisp
152 lines (142 loc) · 6.17 KB
/
cl-portable.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
(in-package :cl-user)
(defpackage :cl-portable
(:use :cl)
(:documentation
"Portable Common Lisp Code")
(:export :quit-with-status
:compile-program
:argument-vector
:argument-script
:platform
:env
:pwd))
(in-package :cl-portable)
(defun quit-with-status (&optional status)
"Quit a program with optional exit status in a portable way."
(when (null status) ;; Fallback to default status
(setq status 0)) ;; when no status is assigned.
;; Disable exit in Swank session.
;; Just return status code to the caller.
#+swank status
;; Exit a program when not in Swank session.
#+sbcl (sb-ext:quit :unix-status status)
#+ccl (if (string= "Microsoft Windows" (software-type))
(ccl:external-call "exit" :int status)
(ccl:quit status))
#+clisp (ext:quit status)
#+ecl (ext:quit status)
#+abcl (ext:quit :status status)
;; Fallback for uncommon CL implementation
#-(or sbcl ccl clisp ecl abcl)
(cl-user::quit status))
(defun compile-program (program main &key type)
(declare (string program) (function main))
"Compile a program to an executable. Support SBCL, CCL and CLISP."
#+sbcl (if (equal :windows (platform))
(let ((_type (if (cl:null type) :console type)))
(sb-ext:save-lisp-and-die program
:toplevel main
:executable t
:application-type _type))
(sb-ext:save-lisp-and-die program
:toplevel main
:executable t))
#+sbcl
(when (and (not (null type))
(not (equal :windows (platform))))
(write-line "Application type is not supported" *error-output*))
#+(not sbcl)
(when (not (null type))
(write-line "Application type is not supported" *error-output*))
#+ccl (ccl:save-application program
:toplevel-function main
:prepend-kernel t)
#+clisp (ext:saveinitmem program
:init-function main
:executable t
:quiet t
:script nil)
#-(or sbcl ccl clisp)
(error "Unsupported Common Lisp implementation"))
(defun argument-vector ()
(declare (ftype (function () list) argument-vector))
"Unprocessed argv (argument vector)"
#+sbcl sb-ext:*posix-argv*
#+ccl ccl:*command-line-argument-list*
#+clisp ext:*args*
#+abcl ext:*command-line-argument-list*
#+ecl (ext:command-args)
#-(or sbcl ccl clisp abcl ecl)
(error "Unsupported Common Lisp implementation"))
(defun argument-script ()
(declare (ftype (function () list) argument-vector))
"Processed command-line argument(s) in scripting mode."
(let* ((args (argument-vector))
#+sbcl (args (rest args))
#+ccl (args (rest (rest (rest (rest (rest (rest args)))))))
#+abcl (args (rest args))
#+ecl (args (rest (rest (rest args))))
;; In CLISP, no loading script in argument(s).
)
(cons *load-truename* args)))
(defun platform ()
(declare (ftype (function () symbol) platform))
"Detect platform type in a portable way."
#+sbcl (cond ((string= "Win32" (software-type)) :windows)
((string= "Darwin" (software-type)) :macos)
((string= "Linux" (software-type)) :linux)
((not (not (find :unix *features*))) :unix)
(t (error "Unknown platform")))
#+ccl (cond ((string= "Microsoft Windows" (software-type)) :windows)
((string= "Darwin" (software-type)) :macos)
((string= "Linux" (software-type)) :linux)
((not (not (find :unix *features*))) :unix)
(t (error "Unknown platform")))
#+clisp (cond ((not (not (find :win32 *features*))) :windows)
((not (not (find :macos *features*))) :macos)
((string= "Linux"
(let ((s (ext:run-program "uname"
:output :stream)))
(read-line s)))
:linux)
((not (not (find :unix *features*))) :unix)
(t (error "Unknown platform")))
#+ecl (cond ((string= "NT" (software-type)) :windows)
((string= "Darwin" (software-type)) :macos)
((string= "Linux" (software-type)) :linux)
((not (not (find :unix *features*))) :unix)
(t (error "Unknown platform")))
#+abcl (cond ((not (not (find :windows *features*))) :windows)
((string= "Mac OS X" (software-type)) :macos)
((string= "Linux" (software-type)) :linux)
((not (not (find :unix *features*))) :unix)
(t (error "Unknown platform")))
#-(or sbcl ccl clisp ecl abcl)
(error "Unsupported Common Lisp implementation"))
(defun env (var &optional default)
"Get an environment variable in a portable way"
(or #+sbcl (sb-ext:posix-getenv var)
#+ccl (ccl:getenv var)
#+clisp (ext:getenv var)
#+ecl (si:getenv var)
#+abcl (ext:getenv var)
default))
;; Not exported.
(defun run-program (cmd args &key (input nil) (output nil))
#+sbcl (sb-ext:run-program cmd args :search "/bin/sh" :input input :output output)
#+ccl (ccl:run-program cmd args :input input :output output)
;; FIXME: argument #<OUTPUT STRING-OUTPUT-STREAM>
;; should be a string, a symbol or a character
#+clisp (ext:run-program cmd :arguments args :input input :output output)
#+ecl (ext:run-program cmd args :input input :output output)
#+abcl (run-program cmd args :input input :output output)
)
(defun pwd ()
"Get current working directory in a portable way"
#+sbcl (pathname (concatenate 'string (sb-posix:getcwd) "/"))
#+ccl (pathname (ccl:current-directory))
;; FIXME: Change slash and remove trailing newline.
#+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
#-(or sbcl ccl clisp)
(pathname (string-trim "." (namestring (truename "."))))
)