;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!EXT")
+(in-package "SB!IMPL")
-(file-comment
- "$Header$")
+;;; something not EQ to anything we might legitimately READ
+(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
+
+;;; a type used for indexing into arrays, and for related quantities
+;;; like lengths of lists
+;;;
+;;; It's intentionally limited to one less than the
+;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
+;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
+;;; that lets the system know it can increment a value of this type
+;;; without having to worry about using a bignum to represent the
+;;; result.
+;;;
+;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
+;;; bound because ANSI specifies it as an exclusive bound.)
+(def!type index () `(integer 0 (,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
(defconstant escape-char-code 27)
(defconstant rubout-char-code 127)
\f
-;;; Concatenate together the names of some strings and symbols,
-;;; producing a symbol in the current package.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate))
- (defun symbolicate (&rest things)
- (values (intern (apply #'concatenate
- 'string
- (mapcar #'string things))))))
-
-;;; like SYMBOLICATE, but producing keywords
-(defun keywordicate (&rest things)
- (let ((*package* *keyword-package*))
- (apply #'symbolicate things)))
-\f
;;;; miscellaneous iteration extensions
(defmacro dovector ((elt vector &optional result) &rest forms)
(let ((n 0))
(dolist (arg args)
(unless (= (length arg) 2)
- (error "bad arg spec: ~S" arg))
+ (error "bad argument spec: ~S" arg))
(let ((arg-name (first arg))
(test (second arg)))
(arg-vars arg-name)
\f
;;;; miscellany
-;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead?
-;;; If nothing, replace it.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun concat-pnames (name1 name2)
- (declare (symbol name1 name2))
- (if name1
- (intern (concatenate 'simple-string
- (symbol-name name1)
- (symbol-name name2)))
- name2)))
-
;;; Is NAME a legal function name?
(defun legal-function-name-p (name)
(or (symbolp name)
(symbolp (cadr name))
(null (cddr name)))))
-;;; Given a function name, return the name for the BLOCK which encloses its
-;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+;;; Given a function name, return the name for the BLOCK which
+;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
(defun function-name-block-name (function-name)
(cond ((symbolp function-name)
(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)
- (declare (type (and unsigned-byte fixnum) 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)))
+
+;;; ANSI guarantees that some symbols are self-evaluating. This
+;;; function is to be called just before a change which would affect
+;;; that. (We don't absolutely have to call this function before such
+;;; changes, since such changes are given as undefined behavior. In
+;;; particular, we don't if the runtime cost would be annoying. But
+;;; otherwise it's nice to do so.)
+(defun about-to-modify (symbol)
+ (declare (type symbol symbol))
+ (cond ((eq symbol t)
+ (error "Veritas aeterna. (can't change T)"))
+ ((eq symbol nil)
+ (error "Nihil ex nihil. (can't change NIL)"))
+ ((keywordp symbol)
+ (error "Keyword values can't be changed."))
+ ;; (Just because a value is CONSTANTP is not a good enough
+ ;; reason to complain here, because we want DEFCONSTANT to
+ ;; be able to use this function, and it's legal to DEFCONSTANT
+ ;; a constant as long as the new value is EQL to the old
+ ;; value.)
+ ))
+\f
+;;;; DEFPRINTER
+
+;;; 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))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+(defun defprinter-print-space (stream)
+ (write-char #\space stream))
+
+;;; Define some kind of reasonable PRINT-OBJECT method for a
+;;; STRUCTURE-OBJECT class.
+;;;
+;;; NAME is the name of the structure class, and CONC-NAME is the same
+;;; as in DEFSTRUCT.
+;;;
+;;; The SLOT-DESCS describe how each slot should be printed. Each
+;;; SLOT-DESC can be a slot name, indicating that the slot should
+;;; simply be printed. A SLOT-DESC may also be a list of a slot name
+;;; and other stuff. The other stuff is composed of keywords followed
+;;; by expressions. The expressions are evaluated with the variable
+;;; which is the slot name bound to the value of the slot. These
+;;; keywords are defined:
+;;;
+;;; :PRIN1 Print the value of the expression instead of the slot value.
+;;; :PRINC Like :PRIN1, only princ the value
+;;; :TEST Only print something if the test is true.
+;;;
+;;; If no printing thing is specified then the slot value is printed
+;;; as if by PRIN1.
+;;;
+;;; The structure being printed is bound to STRUCTURE and the stream
+;;; is bound to STREAM.
+(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-")))
+ &rest slot-descs)
+ (let ((first? t)
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (gensym "STREAM")))
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (dolist (slot-desc slot-descs)
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
+ `(def!method print-object ((structure ,name) ,stream)
+ ;; 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
projects / sbcl.git / blobdiff