-;;;; This file contains definitions and declarations for the
-;;;; EXTENSIONS package which must be available at early cross-compile
-;;;; time, and perhaps also some things which might as well be built
-;;;; at cross-compile time even if they're not strictly needed, since
-;;;; that's harmless. Things which can't be built at cross-compile
-;;;; time (e.g. because they need machinery which only exists inside
-;;;; CMU CL's implementation of the LISP package) do not belong in
-;;;; this file.
+;;;; various extensions (including SB-INT "internal extensions")
+;;;; available both in the cross-compilation host Lisp and in the
+;;;; target SBCL
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!IMPL")
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
;;; something not EQ to anything we might legitimately READ
(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
;;; bound because ANSI specifies it as an exclusive bound.)
(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
+;;; like INDEX, but augmented with -1 (useful when using the index
+;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
+;;; an implementation which terminates the loop by testing for the
+;;; index leaving the loop range)
+(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
;;; because it's not in the ANSI table of portable characters.
(defconstant escape-char-code 27)
(defconstant rubout-char-code 127)
\f
+;;;; type-ish predicates
+
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Return true if X is a proper list whose length is between MIN and
+ ;; MAX (inclusive).
+ (defun proper-list-of-length-p (x min &optional (max min))
+ ;; FIXME: This implementation will hang on circular list
+ ;; structure. Since this is an error-checking utility, i.e. its
+ ;; job is to deal with screwed-up input, it'd be good style to fix
+ ;; it so that it can deal with circular list structure.
+ (cond ((minusp max)
+ nil)
+ ((null x)
+ (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil))))
+
+;;; Is X a circular list?
+(defun circular-list-p (x)
+ (and (listp x)
+ (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
+ (do ((y x (safe-cddr y))
+ (started-p nil t)
+ (z x (cdr z)))
+ ((not (and (consp z) (consp y))) nil)
+ (when (and started-p (eq y z))
+ (return t))))))
+
+;;; Is X a (possibly-improper) list of at least N elements?
+(declaim (ftype (function (t index)) list-of-length-at-least-p))
+(defun list-of-length-at-least-p (x n)
+ (or (zerop n) ; since anything can be considered an improper list of length 0
+ (and (consp x)
+ (list-of-length-at-least-p (cdr x) (1- n)))))
+
+;;; Is X is a positive prime integer?
+(defun positive-primep (x)
+ ;; This happens to be called only from one place in sbcl-0.7.0, and
+ ;; only for fixnums, we can limit it to fixnums for efficiency. (And
+ ;; if we didn't limit it to fixnums, we should use a cleverer
+ ;; algorithm, since this one scales pretty badly for huge X.)
+ (declare (fixnum x))
+ (if (<= x 5)
+ (and (>= x 2) (/= x 4))
+ (and (not (evenp x))
+ (not (zerop (rem x 3)))
+ (do ((q 6)
+ (r 1)
+ (inc 2 (logxor inc 6)) ;; 2,4,2,4...
+ (d 5 (+ d inc)))
+ ((or (= r 0) (> d q)) (/= r 0))
+ (declare (fixnum inc))
+ (multiple-value-setq (q r) (truncate x d))))))
+\f
+;;;; the COLLECT macro
+;;;;
+;;;; comment from CMU CL: "the ultimate collection macro..."
+
+;;; helper functions for COLLECT, which become the expanders of the
+;;; MACROLET definitions created by COLLECT
+;;;
+;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
+;;;
+;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
+;;; is the pointer to the current tail of the list, or NIL if the list
+;;; is empty.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun collect-normal-expander (n-value fun forms)
+ `(progn
+ ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
+ ,n-value))
+ (defun collect-list-expander (n-value n-tail forms)
+ (let ((n-res (gensym)))
+ `(progn
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
+
+;;; Collect some values somehow. Each of the collections specifies a
+;;; bunch of things which collected during the evaluation of the body
+;;; of the form. The name of the collection is used to define a local
+;;; macro, a la MACROLET. Within the body, this macro will evaluate
+;;; each of its arguments and collect the result, returning the
+;;; current value after the collection is done. The body is evaluated
+;;; as a PROGN; to get the final values when you are done, just call
+;;; the collection macro with no arguments.
+;;;
+;;; INITIAL-VALUE is the value that the collection starts out with,
+;;; which defaults to NIL. FUNCTION is the function which does the
+;;; collection. It is a function which will accept two arguments: the
+;;; value to be collected and the current collection. The result of
+;;; the function is made the new value for the collection. As a
+;;; totally magical special-case, FUNCTION may be COLLECT, which tells
+;;; us to build a list in forward order; this is the default. If an
+;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; onto the end. Note that FUNCTION may be anything that can appear
+;;; in the functional position, including macros and lambdas.
+(defmacro collect (collections &body body)
+ (let ((macros ())
+ (binds ()))
+ (dolist (spec collections)
+ (unless (proper-list-of-length-p spec 1 3)
+ (error "malformed collection specifier: ~S." spec))
+ (let* ((name (first spec))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
+ `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+\f
+;;;; some old-fashioned functions. (They're not just for old-fashioned
+;;;; code, they're also used as optimized forms of the corresponding
+;;;; general functions when the compiler can prove that they're
+;;;; equivalent.)
+
+;;; like (MEMBER ITEM LIST :TEST #'EQ)
+(defun memq (item list)
+ #!+sb-doc
+ "Returns tail of LIST beginning with first element EQ to ITEM."
+ ;; KLUDGE: These could be and probably should be defined as
+ ;; (MEMBER ITEM LIST :TEST #'EQ)),
+ ;; but when I try to cross-compile that, I get an error from
+ ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
+ ;; comments for that error say it "is probably a botched interpreter stub".
+ ;; Rather than try to figure that out, I just rewrote this function from
+ ;; scratch. -- WHN 19990512
+ (do ((i list (cdr i)))
+ ((null i))
+ (when (eq (car i) item)
+ (return i))))
+
+;;; like (ASSOC ITEM ALIST :TEST #'EQ):
+;;; Return the first pair of ALIST where ITEM is EQ to the key of
+;;; the pair.
+(defun assq (item alist)
+ ;; KLUDGE: CMU CL defined this with
+ ;; (DECLARE (INLINE ASSOC))
+ ;; (ASSOC ITEM ALIST :TEST #'EQ))
+ ;; which is pretty, but which would have required adding awkward
+ ;; build order constraints on SBCL (or figuring out some way to make
+ ;; inline definitions installable at build-the-cross-compiler time,
+ ;; which was too ambitious for now). Rather than mess with that, we
+ ;; just define ASSQ explicitly in terms of more primitive
+ ;; operations:
+ (dolist (pair alist)
+ (when (eq (car pair) item)
+ (return pair))))
+
+;;; like (DELETE .. :TEST #'EQ):
+;;; Delete all LIST entries EQ to ITEM (destructively modifying
+;;; LIST), and return the modified LIST.
+(defun delq (item list)
+ (let ((list list))
+ (do ((x list (cdr x))
+ (splice '()))
+ ((endp x) list)
+ (cond ((eq item (car x))
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))) ; Move splice along to include element.
+
+
+;;; like (POSITION .. :TEST #'EQ):
+;;; Return the position of the first element EQ to ITEM.
+(defun posq (item list)
+ (do ((i list (cdr i))
+ (j 0 (1+ j)))
+ ((null i))
+ (when (eq (car i) item)
+ (return j))))
+
+(declaim (inline neq))
+(defun neq (x y)
+ (not (eq x y)))
+\f
;;;; miscellaneous iteration extensions
-(defmacro dovector ((elt vector &optional result) &rest forms)
+;;; "the ultimate iteration macro"
+;;;
+;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+(defmacro named-let (name binds &body body)
#!+sb-doc
- "just like DOLIST, but with one-dimensional arrays"
+ (dolist (x binds)
+ (unless (proper-list-of-length-p x 2)
+ (error "malformed NAMED-LET variable spec: ~S" x)))
+ `(labels ((,name ,(mapcar #'first binds) ,@body))
+ (,name ,@(mapcar #'second binds))))
+
+;;; just like DOLIST, but with one-dimensional arrays
+(defmacro dovector ((elt vector &optional result) &rest forms)
(let ((index (gensym))
(length (gensym))
(vec (gensym)))
(let ((,elt (aref ,vec ,index)))
,@forms)))))
+;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- #!+sb-doc
- "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
- Iterate over the entries in a hash-table."
(multiple-value-bind (forms decls) (parse-body body nil)
(let ((gen (gensym))
(n-more (gensym)))
:format-control "The package ~S has been deleted."
:format-arguments (list maybe-result)))))
\f
-;;;; miscellany
+;;;; various operations on names
;;; Is NAME a legal function name?
(defun legal-function-name-p (name)
(t
(error "not legal as a function name: ~S" function-name))))
-;;; Is X a (possibly-improper) list of at least N elements?
-(declaim (ftype (function (t index)) list-of-length-at-least-p))
-(defun list-of-length-at-least-p (x n)
- (or (zerop n) ; since anything can be considered an improper list of length 0
- (and (consp x)
- (list-of-length-at-least-p (cdr x) (1- n)))))
-
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
+(defun looks-like-name-of-special-var-p (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (> (length name) 2) ; to exclude '* and '**
+ (char= #\* (aref name 0))
+ (char= #\* (aref name (1- (length name))))))))
;;; ANSI guarantees that some symbols are self-evaluating. This
;;; function is to be called just before a change which would affect
;; a constant as long as the new value is EQL to the old
;; value.)
))
+\f
+;;;; ONCE-ONLY
+;;;;
+;;;; "The macro ONCE-ONLY has been around for a long time on various
+;;;; systems [..] if you can understand how to write and when to use
+;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
+;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
+;;;; in Common Lisp_, p. 853
+
+;;; ONCE-ONLY is a utility useful in writing source transforms and
+;;; macros. It provides a concise way to wrap a LET around some code
+;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.
+(defmacro once-only (specs &body body)
+ (named-let frob ((specs specs)
+ (body body))
+ (if (null specs)
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym (symbol-name name))))
+ `(let ((,exp-temp ,(second spec))
+ (,name (gensym "ONCE-ONLY-")))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
+\f
+;;;; various error-checking utilities
+
+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.
+(declaim (ftype (function () nil) required-argument))
+(defun required-argument ()
+ #!+sb-doc
+ (/show0 "entering REQUIRED-ARGUMENT")
+ (error "A required &KEY argument was not supplied."))
+
+;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
+;;; The CL:ASSERT restarts and whatnot expand into a significant
+;;; amount of code when you multiply them by 400, so replacing them
+;;; with this should reduce the size of the system by enough to be
+;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
+;;; worthwhile, and since I don't really like CERROR stuff deep in the
+;;; guts of complex systems anyway, I replaced it too.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(let ((*package* (find-package :keyword)))
+ (format nil "~S" expr)))))
+(defun %failed-aver (expr-as-string)
+ (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+(defmacro enforce-type (value type)
+ (once-only ((value value))
+ `(unless (typep ,value ',type)
+ (%failed-enforce-type ,value ',type))))
+(defun %failed-enforce-type (value type)
+ (error 'simple-type-error
+ :value value
+ :expected-type type
+ :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-arguments (list value type)))
+\f
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+ (loop repeat n collect (gensym)))
;;; Return a function like FUN, but expecting its (two) arguments in
;;; the opposite order that FUN does.
(lambda (x y)
(funcall fun y x)))
-;;; like CL:ASSERT, but lighter-weight
-;;;
-;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT
-;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a
-;;; significant amount of code when you multiply them by 400, so
-;;; replacing them with this should reduce the size of the system
-;;; by enough to be worthwhile.)
-(defmacro aver (expr)
- `(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
-(defun %failed-aver (expr-as-string)
- (error "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
-
;;; Return the numeric value of a type bound, i.e. an interval bound
;;; more or less in the format of bounds in ANSI's type specifiers,
;;; where a bare numeric value is a closed bound and a list of a
(if (consp x)
(destructuring-bind (result) x result)
x))
+
+;;; some commonly-occuring CONSTANTLY forms
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
+
+;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; handle arbitrary combinations of atoms using NOT, AND, OR.
+(defun featurep (x)
+ (if (consp x)
+ (case (car x)
+ ((:not not)
+ (if (cddr x)
+ (error "too many subexpressions in feature expression: ~S" x)
+ (not (featurep (cadr x)))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x)))
+ (not (null (memq x *features*)))))
+
+;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
+;;; &KEY-argument-list-style list of alternating keywords and
+;;; arbitrary values, return a new &KEY-argument-list-style list with
+;;; all substitutions applied to it.
+;;;
+;;; Note: If efficiency mattered, we could do less consing. (But if
+;;; efficiency mattered, why would we be using &KEY arguments at
+;;; all, much less renaming &KEY arguments?)
+;;;
+;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
+(defun rename-key-args (rename-list key-args)
+ (declare (type list rename-list key-args))
+ ;; Walk through RENAME-LIST modifying RESULT as per each element in
+ ;; RENAME-LIST.
+ (do ((result (copy-list key-args))) ; may be modified below
+ ((null rename-list) result)
+ (destructuring-bind (old new) (pop rename-list)
+ ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
+ (declare (type symbol old new))
+ ;; Walk through RESULT renaming any OLD key argument to NEW.
+ (do ((in-result result (cddr in-result)))
+ ((null in-result))
+ (declare (type list in-result))
+ (when (eq (car in-result) old)
+ (setf (car in-result) new))))))
+
+;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
+;;; other ANSI input functions, is defined to communicate end of file
+;;; status with its return value, not by signalling. That is not the
+;;; behavior that we usually want. This function is a wrapper which
+;;; restores the behavior that we usually want, causing READ-SEQUENCE
+;;; to communicate end-of-file status by signalling.
+(defun read-sequence-or-die (sequence stream &key start end)
+ ;; implementation using READ-SEQUENCE
+ #-no-ansi-read-sequence
+ (let ((read-end (read-sequence sequence
+ stream
+ :start start
+ :end end)))
+ (unless (= read-end end)
+ (error 'end-of-file :stream stream))
+ (values))
+ ;; workaround for broken READ-SEQUENCE
+ #+no-ansi-read-sequence
+ (progn
+ (aver (<= start end))
+ (let ((etype (stream-element-type stream)))
+ (cond ((equal etype '(unsigned-byte 8))
+ (do ((i start (1+ i)))
+ ((>= i end)
+ (values))
+ (setf (aref sequence i)
+ (read-byte stream))))
+ (t (error "unsupported element type ~S" etype))))))
\f
;;;; utilities for two-VALUES predicates
;;; These functions are called by the expansion of the DEFPRINTER
;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream &optional t) (values))
+(declaim (ftype (function (symbol t stream) (values))
defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream &optional indent)
- (declare (ignore indent))
+(defun defprinter-prin1 (name value stream)
(defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream &optional indent)
- (declare (ignore indent))
+(defun defprinter-princ (name value stream)
(defprinter-prinx #'princ name value stream))
(defun defprinter-prinx (prinx name value stream)
(declare (type function prinx))
;; FIXME: should probably be byte-compiled
(pprint-logical-block (,stream nil)
(print-unreadable-object (structure ,stream :type t)
- (when *print-pretty*
- (pprint-indent :block 2 ,stream))
,@(nreverse reversed-prints))))))
\f
-#|
-;;; REMOVEME when done testing byte cross-compiler
-(defun byte-compiled-foo (x y)
- (declare (optimize (speed 0) (debug 1)))
- (if x
- x
- (cons y y)))
-|#
+;;;; etc.
+
+;;; Given a pathname, return a corresponding physical pathname.
+(defun physicalize-pathname (possibly-logical-pathname)
+ (if (typep possibly-logical-pathname 'logical-pathname)
+ (translate-logical-pathname possibly-logical-pathname)
+ possibly-logical-pathname))