common-lisp.lisp - clic - Clic is an command line interactive client for gopher… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
common-lisp.lisp (10117B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; Handle compatibility with multiple implementations. | |
3 ;;; This file is for papering over the deficiencies and peculiarities | |
4 ;;; of various Common Lisp implementations. | |
5 ;;; For implementation-specific access to the system, see os.lisp instea… | |
6 ;;; A few functions are defined here, but actually exported from utility; | |
7 ;;; from this package only common-lisp symbols are exported. | |
8 | |
9 (uiop/package:define-package :uiop/common-lisp | |
10 (:nicknames :uoip/cl) | |
11 (:use :uiop/package) | |
12 (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) | |
13 #+allegro (:intern #:*acl-warn-save*) | |
14 #+cormanlisp (:shadow #:user-homedir-pathname) | |
15 #+cormanlisp | |
16 (:export | |
17 #:logical-pathname #:translate-logical-pathname | |
18 #:make-broadcast-stream #:file-namestring) | |
19 #+genera (:shadowing-import-from :scl #:boolean) | |
20 #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence… | |
21 #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) | |
22 (in-package :uiop/common-lisp) | |
23 | |
24 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera l… | |
25 (error "ASDF is not supported on your implementation. Please help us por… | |
26 | |
27 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust im… | |
28 | |
29 | |
30 ;;;; Early meta-level tweaks | |
31 | |
32 #+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl) | |
33 (eval-when (:load-toplevel :compile-toplevel :execute) | |
34 (when (and #+allegro (member :ics *features*) | |
35 #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicod… | |
36 #+clozure (member :openmcl-unicode-strings *features*) | |
37 #+sbcl (member :sb-unicode *features*)) | |
38 ;; Check for unicode at runtime, so that a hypothetical FASL compile… | |
39 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell … | |
40 (pushnew :asdf-unicode *features*))) | |
41 | |
42 #+allegro | |
43 (eval-when (:load-toplevel :compile-toplevel :execute) | |
44 ;; We need to disable autoloading BEFORE any mention of package ASDF. | |
45 ;; In particular, there must NOT be a mention of package ASDF in the d… | |
46 ;; or any previous file. | |
47 (setf excl::*autoload-package-name-alist* | |
48 (remove "asdf" excl::*autoload-package-name-alist* | |
49 :test 'equalp :key 'car)) | |
50 (defparameter *acl-warn-save* | |
51 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) | |
52 excl:*warn-on-nested-reader-conditionals*)) | |
53 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) | |
54 (setf excl:*warn-on-nested-reader-conditionals* nil)) | |
55 (setf *print-readably* nil)) | |
56 | |
57 #+clasp | |
58 (eval-when (:load-toplevel :compile-toplevel :execute) | |
59 (setf *load-verbose* nil) | |
60 (defun use-ecl-byte-compiler-p () nil)) | |
61 | |
62 #+clozure (in-package :ccl) | |
63 #+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket… | |
64 (eval-when (:load-toplevel :compile-toplevel :execute) | |
65 (unless (fboundp 'external-process-wait) | |
66 (in-development-mode | |
67 (defun external-process-wait (proc) | |
68 (when (and (external-process-pid proc) (eq (external-process-%sta… | |
69 (with-interrupts-enabled | |
70 (wait-on-semaphore (external-process-completed proc)))) | |
71 (values (external-process-%exit-code proc) | |
72 (external-process-%status proc)))))) | |
73 #+clozure (in-package :uiop/common-lisp) ;; back in this package. | |
74 | |
75 #+cmucl | |
76 (eval-when (:load-toplevel :compile-toplevel :execute) | |
77 (setf ext:*gc-verbose* nil) | |
78 (defun user-homedir-pathname () | |
79 (first (ext:search-list (cl:user-homedir-pathname))))) | |
80 | |
81 #+cormanlisp | |
82 (eval-when (:load-toplevel :compile-toplevel :execute) | |
83 (deftype logical-pathname () nil) | |
84 (defun make-broadcast-stream () *error-output*) | |
85 (defun translate-logical-pathname (x) x) | |
86 (defun user-homedir-pathname (&optional host) | |
87 (declare (ignore host)) | |
88 (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) | |
89 (defun file-namestring (p) | |
90 (setf p (pathname p)) | |
91 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) | |
92 | |
93 #+ecl | |
94 (eval-when (:load-toplevel :compile-toplevel :execute) | |
95 (setf *load-verbose* nil) | |
96 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*… | |
97 (unless (use-ecl-byte-compiler-p) (require :cmp))) | |
98 | |
99 #+gcl | |
100 (eval-when (:load-toplevel :compile-toplevel :execute) | |
101 (unless (member :ansi-cl *features*) | |
102 (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) | |
103 (setf compiler::*compiler-default-type* (pathname "") | |
104 compiler::*lsp-ext* "") | |
105 #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013… | |
106 (cond | |
107 #+gcl | |
108 ((or (< system::*gcl-major-version* 2) | |
109 (and (= system::*gcl-major-version* 2) | |
110 (< system::*gcl-minor-version* 7))) | |
111 '(error "GCL 2.7 or later required to use ASDF"))))) | |
112 (eval code) | |
113 code)) | |
114 | |
115 #+genera | |
116 (eval-when (:load-toplevel :compile-toplevel :execute) | |
117 (unless (fboundp 'lambda) | |
118 (defmacro lambda (&whole form &rest bvl-decls-and-body) | |
119 (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) | |
120 `#',(cons 'lisp::lambda (cdr form)))) | |
121 (unless (fboundp 'ensure-directories-exist) | |
122 (defun ensure-directories-exist (path) | |
123 (fs:create-directories-recursively (pathname path)))) | |
124 (unless (fboundp 'read-sequence) | |
125 (defun read-sequence (sequence stream &key (start 0) end) | |
126 (scl:send stream :string-in nil sequence start end))) | |
127 (unless (fboundp 'write-sequence) | |
128 (defun write-sequence (sequence stream &key (start 0) end) | |
129 (scl:send stream :string-out sequence start end) | |
130 sequence))) | |
131 | |
132 #+lispworks | |
133 (eval-when (:load-toplevel :compile-toplevel :execute) | |
134 ;; lispworks 3 and earlier cannot be checked for so we always assume | |
135 ;; at least version 4 | |
136 (unless (member :lispworks4 *features*) | |
137 (pushnew :lispworks5+ *features*) | |
138 (unless (member :lispworks5 *features*) | |
139 (pushnew :lispworks6+ *features*) | |
140 (unless (member :lispworks6 *features*) | |
141 (pushnew :lispworks7+ *features*))))) | |
142 | |
143 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+m… | |
144 (read-from-string | |
145 "(eval-when (:load-toplevel :compile-toplevel :execute) | |
146 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) … | |
147 (ccl:define-entry-point (_system \"system\") ((name :string)) … | |
148 ;; Note: ASDF may expect user-homedir-pathname to provide | |
149 ;; the pathname of the current user's home directory, whereas | |
150 ;; MCL by default provides the directory from which MCL was st… | |
151 ;; See http://code.google.com/p/mcl/wiki/Portability | |
152 (defun user-homedir-pathname () | |
153 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) | |
154 (defun probe-posix (posix-namestring) | |
155 \"If a file exists for the posix namestring, return the path… | |
156 (ccl::with-cstrs ((cpath posix-namestring)) | |
157 (ccl::rlet ((is-dir :boolean) | |
158 (fsref :fsref)) | |
159 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) | |
160 (ccl::%path-from-fsref fsref is-dir))))))")) | |
161 | |
162 #+mkcl | |
163 (eval-when (:load-toplevel :compile-toplevel :execute) | |
164 (require :cmp) | |
165 (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict … | |
166 | |
167 | |
168 ;;;; Looping | |
169 (eval-when (:load-toplevel :compile-toplevel :execute) | |
170 (defmacro loop* (&rest rest) | |
171 #-genera `(loop ,@rest) | |
172 #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructu… | |
173 | |
174 | |
175 ;;;; compatfmt: avoid fancy format directives when unsupported | |
176 (eval-when (:load-toplevel :compile-toplevel :execute) | |
177 (defun frob-substrings (string substrings &optional frob) | |
178 "for each substring in SUBSTRINGS, find occurrences of it within STR… | |
179 that don't use parts of matched occurrences of previous strings, and | |
180 FROB them, that is to say, remove them if FROB is NIL, | |
181 replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, | |
182 call FROB with the match and a function that emits a string in the outpu… | |
183 Return a string made of the parts not omitted or emitted by FROB." | |
184 (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3))) | |
185 (let ((length (length string)) (stream nil)) | |
186 (labels ((emit-string (x &optional (start 0) (end (length x))) | |
187 (when (< start end) | |
188 (unless stream (setf stream (make-string-output-strea… | |
189 (write-string x stream :start start :end end))) | |
190 (emit-substring (start end) | |
191 (when (and (zerop start) (= end length)) | |
192 (return-from frob-substrings string)) | |
193 (emit-string string start end)) | |
194 (recurse (substrings start end) | |
195 (cond | |
196 ((>= start end)) | |
197 ((null substrings) (emit-substring start end)) | |
198 (t (let* ((sub-spec (first substrings)) | |
199 (sub (if (consp sub-spec) (car sub-spec) su… | |
200 (fun (if (consp sub-spec) (cdr sub-spec) fr… | |
201 (found (search sub string :start2 start :en… | |
202 (more (rest substrings))) | |
203 (cond | |
204 (found | |
205 (recurse more start found) | |
206 (etypecase fun | |
207 (null) | |
208 (string (emit-string fun)) | |
209 (function (funcall fun sub #'emit-string))) | |
210 (recurse substrings (+ found (length sub)) en… | |
211 (t | |
212 (recurse more start end)))))))) | |
213 (recurse substrings 0 length)) | |
214 (if stream (get-output-stream-string stream) ""))) | |
215 | |
216 (defmacro compatfmt (format) | |
217 #+(or gcl genera) | |
218 (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~… | |
219 #-(or gcl genera) format)) |