common-lisp.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) 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 instead. 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 #:write-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 lispworks mcl mezzano mkcl sbcl scl xcl) 25 (error "ASDF is not supported on your implementation. Please help us port it.") 26 27 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. 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 :unicode *features*) 36 #+clozure (member :openmcl-unicode-strings *features*) 37 #+sbcl (member :sb-unicode *features*)) 38 ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode 39 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. 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 defpackage of this file 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/1117 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-%status proc) :running)) 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*) t)) 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 or later. 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 #+mcl, so we use this trick 144 (read-from-string 145 "(eval-when (:load-toplevel :compile-toplevel :execute) 146 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) 147 (ccl:define-entry-point (_system \"system\") ((name :string)) :int) 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 started. 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 pathname\" 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 ANSI class redefinition semantics 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 destructure, so we use LOOP*. Sigh. 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 STRING 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 output. 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-stream))) 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) sub-spec)) 200 (fun (if (consp sub-spec) (cdr sub-spec) frob)) 201 (found (search sub string :start2 start :end2 end)) 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)) end)) 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))