added code to support coming changes in (probably) 0.6.11.41..
..moving Unix opendir/readdir/closedir iteration down to the C
level, so that all structure layouts and whatnot can be
read directly from #include files, so that directory
operations become inherently portable (or at least as
much as C/Unix ever is:-) and work on OpenBSD
..replacing old *UNIX-ERROR* cruft with STRERROR and
SIMPLE-PERROR
GET-ERRNO belongs in SB-C-CALL, it's not Unix-specific.
# "When we build software, it's a good idea to have a reliable method
# for getting an executable from it. We want any two reconstructions
-
# starting from the same source to end up in the same result. That's
# just a basic intellectual premise."
# -- Christian Queinnec, in _Lisp In Small Pieces_, p. 313
#s(sb-cold:package-data
:name "SB!C"
:doc "private: implementation of the compiler"
+ ;; (It seems strange to have the compiler USE SB-ALIEN-INTERNALS,
+ ;; but the point seems to be to be able to express things like
+ ;; SB-C:DEFTRANSFORM SB-ALIEN-INTERNALS:MAKE-LOCAL-ALIEN without
+ ;; having to use a bunch of package prefixes, by putting them
+ ;; in the SB-C package. Maybe it'd be tidier to define an SB-ALIEN-COMP
+ ;; package for this? But it seems like a fairly low priority.)
+ ;; (Probably the same considerations also explain why BIGNUM is
+ ;;in the USE list.)
:use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!BIGNUM"
#!+sb-dyncount "SB-DYNCOUNT"
"SB!EXT" "SB!INT" "SB!KERNEL" "SB!ASSEM" "SB!SYS")
:doc "public: some types used with ALIENs"
:use ("CL" "SB!SYS" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!INT" "SB!EXT")
:reexport ("FLOAT" "CHAR")
- :export ("C-STRING" "DOUBLE" "INT" "LONG"
+ :export ("C-STRING" "DOUBLE" "GET-ERRNO" "INT" "LONG"
"SHORT" "UNSIGNED-CHAR" "UNSIGNED-INT"
"UNSIGNED-LONG" "UNSIGNED-SHORT" "VOID"))
;; used for FORMAT tilde paren
"MAKE-CASE-FROB-STREAM"
+ ;; helpers for C library calls
+ "STRERROR" "SIMPLE-PERROR"
+
;; debuggers' little helpers
#!+sb-show "*/SHOW*"
#!+sb-show "HEXSTR"
;; need it:
"*EOF-OBJECT*"
+ ;; alien interface utilities
+ "C-STRINGS->STRING-LIST"
+
;; misc. utilities used internally
"LEGAL-FUNCTION-NAME-P"
"FUNCTION-NAME-BLOCK-NAME"
"DADDR-T" "DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
"F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
"FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
- "F_OK" "GET-UNIX-ERROR-MSG" "GET-ERRNO" "GID-T"
+ "F_OK" "GET-UNIX-ERROR-MSG" "GID-T"
"INO-T" "UNIX-SETITIMER" "UNIX-GETITIMER"
"KBDCGET" "KBDCRESET" "KBDCRST" "KBDCSET"
"KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET" "L_INCR" "L_SET"
(let* ((pathname-directory (%pathname-directory pathname))
(defaults-directory (%pathname-directory defaults))
(prefix-len (length defaults-directory))
- (result-dir
+ (result-directory
(cond ((and (> prefix-len 1)
(>= (length pathname-directory) prefix-len)
(compare-component (subseq pathname-directory
(t
;; We are a relative directory. So we lose.
(lose)))))
- (strings (unparse-unix-directory-list result-dir)))
+ (strings (unparse-unix-directory-list result-directory)))
(let* ((pathname-version (%pathname-version pathname))
(version-needed (and pathname-version
(not (eq pathname-version :newest))))
\f
;;;; wildcard matching stuff
+;;; Return a list of all the Lispy filenames (not including e.g. the
+;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME.
+(defun directory-lispy-filenames (directory-name)
+ (with-alien ((adlf (* c-string)
+ (alien-funcall (extern-alien
+ "alloc_directory_lispy_filenames"
+ (function (* c-string) c-string))
+ directory-name)))
+ (if (null-alien adlf)
+ (error 'simple-file-error
+ :pathname directory-name
+ :format-control "~@<couldn't read directory ~S: ~2I~_~A~:>"
+ :format-arguments (list directory-name (strerror)))
+ (unwind-protect
+ (c-strings->string-list adlf)
+ (alien-funcall (extern-alien "free_directory_lispy_filenames"
+ (function void (* c-string)))
+ adlf)))))
+
(/show0 "filesys.lisp 498")
;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
,@body))))
(do-directory-entries ((name directory) &body body)
`(let ((dir (sb!unix:open-dir ,directory)))
- (when dir
- (unwind-protect
- (loop
- (let ((,name (sb!unix:read-dir dir)))
- (cond ((null ,name)
- (return))
- ((string= ,name "."))
- ((string= ,name ".."))
- (t
- ,@body))))
+ (when dir
+ (unwind-protect
+ (loop
+ (let ((,name (sb!unix:read-dir dir)))
+ (cond ((null ,name)
+ (return))
+ ((string= ,name "."))
+ ((string= ,name ".."))
+ (t
+ ,@body))))
(sb!unix:close-dir dir))))))
(if tail
(let ((piece (car tail)))
(dest (* char))
(src (* char))
(n unsigned-int))
+
+(def-alien-routine ("os_get_errno" get-errno) integer)
+(setf (fdocumentation 'get-errno 'function)
+ "Return the value of the C library pseudo-variable named \"errno\".")
+
+;;; Decode errno into a string.
+(defun strerror (&optional (errno (get-errno)))
+ (alien-funcall (extern-alien "strerror" (function c-string int)) errno))
(defun posix-environ ()
"Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
- (let ((reversed-result nil))
- (dotimes (i most-positive-fixnum (error "can't happen"))
- (declare (type index i))
- (let ((env-item (deref environ i)))
- (if env-item
- (push env-item reversed-result)
- (return (nreverse reversed-result)))))))
+ (c-strings->string-list environ))
;;; Convert as best we can from a SBCL representation of a Unix
;;; environment to a CMU CL representation.
(cond ((not (whitespace-char-p char))
(unread-char char stream)
(return t)))))
+\f
+;;;; helpers for C library calls
+
+;;; Signal a SIMPLE-CONDITION/ERROR condition associated with an ANSI C
+;;; errno problem, arranging for the condition's print representation
+;;; to be similar to the ANSI C perror(3) style.
+(defun simple-perror (prefix-string
+ &key
+ (errno (get-errno))
+ (simple-error 'simple-error)
+ other-condition-args)
+ (declare (type symbol simple-error))
+ (aver (subtypep simple-error 'simple-condition))
+ (aver (subtypep simple-error 'error))
+ (apply #'error
+ simple-error
+ :format-control "~@<~A: ~2I~_~A~:>"
+ :format-arguments (list prefix-string (strerror errno))
+ other-condition-args))
;;; Unparse a logical pathname string.
(defun unparse-enough-namestring (pathname defaults)
- (let* ((path-dir (pathname-directory pathname))
- (def-dir (pathname-directory defaults))
- (enough-dir
+ (let* ((path-directory (pathname-directory pathname))
+ (def-directory (pathname-directory defaults))
+ (enough-directory
;; Go down the directory lists to see what matches. What's
;; left is what we want, more or less.
- (cond ((and (eq (first path-dir) (first def-dir))
- (eq (first path-dir) :absolute))
+ (cond ((and (eq (first path-directory) (first def-directory))
+ (eq (first path-directory) :absolute))
;; Both paths are :ABSOLUTE, so find where the
;; common parts end and return what's left
- (do* ((p (rest path-dir) (rest p))
- (d (rest def-dir) (rest d)))
+ (do* ((p (rest path-directory) (rest p))
+ (d (rest def-directory) (rest d)))
((or (endp p) (endp d)
(not (equal (first p) (first d))))
`(:relative ,@p))))
(t
;; At least one path is :RELATIVE, so just return the
;; original path. If the original path is :RELATIVE,
- ;; then that's the right one. If PATH-DIR is
+ ;; then that's the right one. If PATH-DIRECTORY is
;; :ABSOLUTE, we want to return that except when
- ;; DEF-DIR is :ABSOLUTE, as handled above. so return
+ ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
;; the original directory.
- path-dir))))
+ path-directory))))
(make-pathname :host (pathname-host pathname)
- :directory enough-dir
+ :directory enough-directory
:name (pathname-name pathname)
:type (pathname-type pathname)
:version (pathname-version pathname))))
(/show0 "unix.lisp 21")
-;;;; common machine-independent structures
+;;;; common machine-independent stuff
(eval-when (:compile-toplevel :execute)
) ; EVAL-WHEN
+;;; FIXME: Couldn't all the *UNIX-ERRORS*/*COMPILER-UNIX-ERRORS* cruft
+;;; be replaced by POSIX strerror(3)?
(defvar *unix-errors*)
(/show0 "unix.lisp 52")
(prog1 (when name `(defconstant ,name ,cur))
(setf cur (funcall inc cur 1)))))
`(progn ,@(mapcar #'defform names))))
+
+;;; Given a C-level zero-terminated array of C strings, return a
+;;; corresponding Lisp-level list of SIMPLE-STRINGs.
+(defun c-strings->string-list (c-strings)
+ (declare (type (alien (* c-string)) c-strings))
+ (let ((reversed-result nil))
+ (dotimes (i most-positive-fixnum (error "argh! can't happen"))
+ (declare (type index i))
+ (let ((c-string (deref c-strings i)))
+ (if c-string
+ (push c-string reversed-result)
+ (return (nreverse reversed-result)))))))
\f
;;;; Lisp types used by syscalls
\f
;;;; system calls
-(def-alien-routine ("os_get_errno" get-errno) integer
- "Return the value of the C library pseudo-variable named \"errno\".")
-
(/show0 "unix.lisp 74")
(defun get-unix-error-msg (&optional (error-number (get-errno)))
\f
;;; from stdio.h
+;;; Rename the file with string NAME1 to the string NAME2. NIL and an
+;;; error code is returned if an error occurs.
(defun unix-rename (name1 name2)
- #!+sb-doc
- "Unix-rename renames the file with string NAME1 to the string
- NAME2. NIL and an error code is returned if an error occurs."
(declare (type unix-pathname name1 name2))
(void-syscall ("rename" c-string c-string) name1 name2))
\f
\f
;;;; direntry.h
+(/show0 "unix.lisp 304")
+
(def-alien-type nil
(struct direct
(d-ino long); inode number of entry
(d-reclen unsigned-short) ; length of this record
(d_type unsigned-char)
(d-name (array char 256)))) ; name must be no longer than this
-(/show0 "unix.lisp 289")
-\f
-;;;; dirent.h
-;;; operations on Unix directories
+;;;; dirent.h
;;;; FIXME: It might be really nice to implement these in C, so that
;;;; we don't need to do horrible things like hand-copying the
;;;; direntry struct slot types into an alien struct.
+
;;; FIXME: DIRECTORY is an external symbol of package CL, so we should
;;; use some other name for this low-level implementation type.
(defstruct (directory (:copier nil))
name
(dir-struct (required-argument) :type system-area-pointer))
-(/show0 "unix.lisp 304")
-
(def!method print-object ((dir directory) stream)
(print-unreadable-object (dir stream :type t)
(prin1 (directory-name dir) stream)))
(addr (deref ptr offset)))
len))
+;;; Set up a unix-piping mechanism consisting of
+;;; an input pipe and an output pipe. Return two
+;;; values: if no error occurred the first value is the pipe
+;;; to be read from and the second is can be written to. If
+;;; an error occurred the first value is NIL and the second
+;;; the unix error code.
(defun unix-pipe ()
- #!+sb-doc
- "Unix-pipe sets up a unix-piping mechanism consisting of
- an input pipe and an output pipe. Unix-Pipe returns two
- values: if no error occurred the first value is the pipe
- to be read from and the second is can be written to. If
- an error occurred the first value is NIL and the second
- the unix error code."
(with-alien ((fds (array int 2)))
(syscall ("pipe" (* int))
(values (deref fds 0) (deref fds 1))
;;; And now for something completely different ...
(emit-unix-errors)
\f
-;;;; support routines for dealing with unix pathnames
+;;;; support routines for dealing with Unix pathnames
(defun unix-file-kind (name &optional check-for-links)
#!+sb-doc
(concatenate 'simple-string dir "/" name)
name))))
+;;; Return the pathname with all symbolic links resolved.
(defun unix-resolve-links (pathname)
- #!+sb-doc
- "Returns the pathname with all symbolic links resolved."
(declare (simple-string pathname))
(let ((len (length pathname))
(pending pathname))
(deftransform %sap-alien ((sap type) * * :important t)
(give-up-ir1-transform
+ ;; FIXME: The hardcoded newline here causes more-than-usually
+ ;; screwed-up formatting of the optimization note output.
"could not optimize away %SAP-ALIEN: forced to do runtime ~@
allocation of alien-value structure"))
\f
dynbind.c globals.c interr.c interrupt.c \
monitor.c parse.c print.c purify.c \
regnames.c run-program.c runtime.c save.c search.c \
- time.c validate.c vars.c \
+ time.c util.c validate.c vars.c wrap.c \
${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC}
OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS))))
LDSO_STUBIFY(sinh)
LDSO_STUBIFY(socket)
LDSO_STUBIFY(stat)
+ LDSO_STUBIFY(strerror)
LDSO_STUBIFY(symlink)
LDSO_STUBIFY(sync)
LDSO_STUBIFY(tanh)
/* LDSO_STUBIFY(strcpy) */
/* LDSO_STUBIFY(strcspn) */
/* LDSO_STUBIFY(strdup) */
-/* LDSO_STUBIFY(strerror) */
/* LDSO_STUBIFY(strfry) */
/* LDSO_STUBIFY(strftime) */
/* LDSO_STUBIFY(strlen) */
--- /dev/null
+/*
+ * miscellaneous utilities
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <stdlib.h>
+#include "util.h"
+\f
+/*
+ * voidacc stuff
+ *
+ * The interface is documented in the header file.
+ *
+ * Note that we never end up needing to explicitly set errno, not even
+ * for malloc failure, because Unix98 guarantees errno=ENOMEM for us
+ * automatically in that case.
+ */
+
+int
+voidacc_ctor(struct voidacc *va)
+{
+ va->n_used = 1; /* We begin with 1 entry already for zero termination. */
+ va->n_avail = 4; /* arbitrary initial value */
+ va->result = (void**)calloc(sizeof(void*), va->n_avail);
+ return va->result ? 0 : (-1);
+}
+
+int
+voidacc_acc(struct voidacc *va, void* x)
+{
+ /* Ensure that we have enough space, or die. */
+ if (va->n_used >= va->n_avail) { /* if we've run out of space */
+ /* We need to allocate more space. */
+ int new_n_avail = 1 + 2 * va->n_avail;
+ void** new_result = (void**)calloc(sizeof(void*), new_n_avail);
+ int i;
+ if (!new_result) {
+ return 1;
+ }
+ /* Copy old result into new space. */
+ for (i = va->n_used; --i >= 0; ) {
+ new_result[i] = va->result[i];
+ }
+ free(va->result);
+ va->result = new_result;
+ va->n_avail = new_n_avail;
+ }
+
+ /* If we get to this point, we have enough space to store x.
+ *
+ * Note that since we cleverly counted the 0 as part of the space
+ * used, now we need to subtract one to get the correct offset to
+ * write into.:-| */
+ va->result[va->n_used++ - 1] = x;
+ return 0;
+}
+
+void**
+voidacc_give_away_result(struct voidacc *va)
+{
+ /* (We could do realloc(3) here to try to shrink the result down
+ * to minimum size, but that's not really needed for the the
+ * directory-iteration application this was originally written
+ * for, so for now we just do the simplest thing which could
+ * possibly work.) */
+ void **result_tmp = va->result;
+ va->result = 0;
+ return result_tmp;
+}
+
+void
+voidacc_dtor(struct voidacc *va)
+{
+ /* if result has been allocated and hasn't been given away */
+ if (va->result) {
+ free(voidacc_give_away_result(va));
+ }
+}
--- /dev/null
+/*
+ * miscellaneous utilities
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * a utility to accumulate a zero-terminated array of void* values
+ *
+ * (Ah, lovely C, makes it such a delight to accumulate a collection
+ * whose length isn't known in advance.. but it's probably more fun
+ * than trying to teach the SBCL debugger to walk g++ stack frames, not to
+ * mention dealing with g++'s lovely in-which-file-do-templates-expand
+ * issues; or than trying to use Lisp for all accumulation and having to
+ * hassle about FFIing all the details of opendir/readdir/closedir
+ * and so forth.)
+ *
+ * We more or less simulate C++-style ctors and dtors.
+ */
+typedef struct
+voidacc { /* the accumulator itself, to be treated as an opaque data type */
+/*private:*/
+ void **result;
+ int n_avail;
+ int n_used;
+} voidacc;
+int voidacc_ctor(voidacc*); /* the ctor, returning 0 for success */
+int voidacc_acc(voidacc*, void*); /* Accumulate an element into result,
+ * returning 0 for success. */
+void** voidacc_give_away_result(voidacc*); /* giving away ownership */
+void voidacc_dtor(voidacc*); /* the dtor */
--- /dev/null
+/*
+ * wrappers around low-level operations to provide a simpler interface
+ * to the operations that Lisp needs
+ *
+ * The functions in this file are typically called directly from Lisp.
+ * Thus, when their signature changes, they don't need updates in a .h
+ * file somewhere, but they do need updates in the Lisp code. FIXME:
+ * It would be nice to enforce this at compile time. It mighn't even
+ * be all that hard: make the cross-compiler versions of DEF-ALIEN-FOO
+ * macros accumulate strings in a list which then gets written out at
+ * the end of sbcl2.h at the end of cross-compilation, then rerun
+ * 'make' in src/runtime/ using the new sbcl2.h as sbcl.h (and make
+ * sure that all the files in src/runtime/ include sbcl.h). */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+#include <sys/types.h>
+#include <dirent.h>
+#include <string.h>
+
+#include "util.h"
+\f
+/*
+ * stuff needed by CL:DIRECTORY and other Lisp directory operations
+ */
+
+/* Unix directory operations think of "." and ".." as filenames, but
+ * Lisp directory operations do not. */
+int
+is_lispy_filename(const char *filename)
+{
+ return strcmp(filename, ".") && strcmp(filename, "..");
+}
+
+/* Return a zero-terminated array of strings holding the Lispy filenames
+ * (i.e. excluding the Unix magic "." and "..") in the named directory. */
+char**
+alloc_directory_lispy_filenames(const char *directory_name)
+{
+ DIR *dir_ptr;
+ char **result = 0;
+
+ if (dir_ptr = opendir(directory_name)) { /* if opendir success */
+
+ struct voidacc va;
+
+ if (0 == voidacc_ctor(&va)) { /* if voidacc_ctor success */
+ struct dirent *dirent_ptr;
+
+ while (dirent_ptr = readdir(dir_ptr)) { /* until end of data */
+ char* original_name = dirent_ptr->d_name;
+ if (is_lispy_filename(original_name)) {
+ /* strdup(3) is in Linux and *BSD. If you port
+ * somewhere else that doesn't have it, it's easy
+ * to reimplement. */
+ char* dup_name = strdup(original_name);
+ if (!dup_name) { /* if strdup failure */
+ goto dtors;
+ }
+ if (voidacc_acc(&va, dup_name)) { /* if acc failure */
+ goto dtors;
+ }
+ }
+ }
+ result = (char**)voidacc_give_away_result(&va);
+ }
+
+ dtors:
+ voidacc_dtor(&va);
+ /* ignoring closedir(3) return code, since what could we do?
+ *
+ * "Never ask questions you don't want to know the answer to."
+ * -- William Irving Zumwalt (Rich Cook, _The Wizardry Quested_) */
+ closedir(dir_ptr);
+ }
+
+ return result;
+}
+
+/* Free a result returned by alloc_directory_lispy_filenames. */
+void
+free_directory_lispy_filenames(char** directory_lispy_filenames)
+{
+ char** p;
+
+ /* Free the strings. */
+ for (p = directory_lispy_filenames; *p; ++p) {
+ free(*p);
+ }
+
+ /* Free the table of strings. */
+ free(directory_lispy_filenames);
+}
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.39"
+"0.6.11.40"
# * doesn't catch #if 0 convention for commenting out blocks
# * doesn't catch stale source files which are no longer used
-# There are assembler source lines, too, but there seem to be less than
-# 1000 for each machine type. (Hardly worth considering!:-)
+echo "(ignoring .sh, .S, etc.)"
projects / sbcl.git / commitdiff