X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=7a49785ff25b7e1411ee194ccc2e51127409c8ef;hb=cb7837b769ce190baec60a2159c33099816ea6e3;hp=d8d0d638ebfd59774f94309f0d685b85c112765a;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index d8d0d63..7a49785 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -378,19 +378,52 @@
   (lambda (x y)
     (funcall fun y x)))
 
-;;; like CL:ASSERT, but lighter-weight
+;;; 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
-;;; 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.)
+;;; (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 "~@<failed AVER: ~2I~_~S~:>" 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-aver-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)))
+
+;;; 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
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+  (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))
 
 ;;;; utilities for two-VALUES predicates
 
@@ -421,13 +454,11 @@
 
 ;;; 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))
@@ -508,8 +539,6 @@
        ;; 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))))))
 
 #|