X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=fe0f3195e1994d256240b56033d86c3a11630c8b;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=75ec633be5a830a092f03776d19b1e872b9daa28;hpb=41ed816c7915806abca6b09ecd2136458f27adcc;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 75ec633..fe0f319 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -40,11 +40,20 @@ ;;; alpha platform. -- CSR, 2002-06-24 (def!type unsigned-byte-with-a-bite-out (s bite) (cond ((eq s '*) 'integer) - ((and (integerp s) (> s 1)) + ((and (integerp s) (> s 0)) (let ((bound (ash 1 s))) `(integer 0 ,(- bound bite 1)))) (t - (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) + +;;; Motivated by the mips port. -- CSR, 2002-08-22 +(def!type signed-byte-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- bound bite 1)))) + (t + (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) (def!type load/store-index (scale lowtag min-offset &optional (max-offset min-offset)) @@ -96,29 +105,6 @@ ;;;; 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 list containing a cycle? (defun cyclic-list-p (x) (and (listp x) @@ -551,6 +537,40 @@ ,@(values-names)) (values ,@(values-names))) (values ,@(values-names)))))))))))) + +(defmacro define-cached-synonym + (name &optional (original (symbolicate "%" name))) + (let ((cached-name (symbolicate "%%" name "-cached"))) + `(progn + (defun-cached (,cached-name :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((args equal)) + (apply #',original args)) + (defun ,name (&rest args) + (,cached-name args))))) + +;;; FIXME: maybe not the best place +;;; +;;; FIXME: think of a better name -- not only does this not have the +;;; CAR recursion of EQUAL, it also doesn't have the special treatment +;;; of pathnames, bit-vectors and strings. +;;; +;;; KLUDGE: This means that we will no longer cache specifiers of the +;;; form '(INTEGER (0) 4). This is probably not a disaster. +;;; +;;; A helper function for the type system, which is the main user of +;;; these caches: we must be more conservative than EQUAL for some of +;;; our equality tests, because MEMBER and friends refer to EQLity. +;;; So: +(defun equal-but-no-car-recursion (x y) + (cond + ((eql x y) t) + ((consp x) + (and (consp y) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) + (t nil))) ;;;; package idioms @@ -583,10 +603,24 @@ (defun legal-fun-name-p (name) (or (symbolp name) (and (consp name) - (eq (car name) 'setf) - (consp (cdr name)) - (symbolp (cadr name)) - (null (cddr name))))) + ;; (SETF FOO) + ;; (CLASS-PREDICATE FOO) + (or (and (or (eq (car name) 'setf) + (eq (car name) 'sb!pcl::class-predicate)) + (consp (cdr name)) + (symbolp (cadr name)) + (null (cddr name))) + ;; (SLOT-ACCESSOR + ;; [READER|WRITER|BOUNDP]) + (and (eq (car name) 'sb!pcl::slot-accessor) + (consp (cdr name)) + (symbolp (cadr name)) + (consp (cddr name)) + (symbolp (caddr name)) + (consp (cdddr name)) + (member + (cadddr name) + '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp))))))) ;;; Signal an error unless NAME is a legal function name. (defun legal-fun-name-or-type-error (name) @@ -597,16 +631,23 @@ :format-control "invalid function name: ~S" :format-arguments (list 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 symbol embedded in it. +;;; +;;; The ordinary use for this operator (and the motivation for the +;;; name of this operator) is to convert from a function name to the +;;; name of the BLOCK which encloses its body. +;;; +;;; Occasionally the operator is useful elsewhere, where the operator +;;; name is less mnemonic. (Maybe it should be changed?) (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) (defun fun-name-block-name (fun-name) (cond ((symbolp fun-name) fun-name) ((and (consp fun-name) - (= (length fun-name) 2) - (eq (first fun-name) 'setf)) - (second fun-name)) + (legal-fun-name-p fun-name)) + (case (car fun-name) + ((setf sb!pcl::class-predicate) (second fun-name)) + ((sb!pcl::slot-accessor) (third fun-name)))) (t (error "not legal as a function name: ~S" fun-name)))) @@ -875,6 +916,15 @@ which can be found at .~:@>" ;;;; utilities for two-VALUES predicates +(defmacro and/type (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2)))))))) + ;;; sort of like ANY and EVERY, except: ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. ;;; (And if the result is uncertain, then we return (VALUES NIL NIL), @@ -1006,3 +1056,17 @@ which can be found at .~:@>" (warn "using deprecated ~S~@[, should use ~S instead~]" bad-name good-name)) + +;;; Anaphoric macros +(defmacro awhen (test &body body) + `(let ((it ,test)) + (when it ,@body))) + +(defmacro acond (&rest clauses) + (if (null clauses) + `() + (destructuring-bind ((test &body body) &rest rest) clauses + (once-only ((test test)) + `(if ,test + (let ((it ,test)) (declare (ignorable it)),@body) + (acond ,@rest))))))